diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,15 @@ # Changelog for pantry +## v0.9.0 + +* Remove module `Pantry.Internal.AesonExtended` and depend on + `aeson-warning-parser` package. +* Remove module `Pantry.Internal.Companion` and depend on `companion` package. +* Remove module `Pantry.Internal.StaticBytes` and depend on `static-bytes` + package. +* Remove module `Pantry.Internal`, previously exposed only for testing. +* Update Hackage bootstrap root key set. + ## v0.8.3 * Expose `withPantryConfig'`, which allows for optional use of Casa. diff --git a/app/test-pretty-exceptions/Main.hs b/app/test-pretty-exceptions/Main.hs --- a/app/test-pretty-exceptions/Main.hs +++ b/app/test-pretty-exceptions/Main.hs @@ -197,6 +197,7 @@ , [ InvalidCabalFilePath pathAbsFileExample ] , [ DuplicatePackageNames sourceMsgExample duplicatePackageNamesExamples ] , [ MigrationFailure descriptionExample pathAbsFileExample someExceptionExample ] + , [ NoCasaConfig ] , [ InvalidTreeFromCasa blobKeyExample blobExample ] , [ ParseSnapNameException rawSnapNameExample ] , [ HpackLibraryException pathAbsFileExample errorMessageExample ] diff --git a/int/Pantry/HPack.hs b/int/Pantry/HPack.hs new file mode 100644 --- /dev/null +++ b/int/Pantry/HPack.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Pantry.HPack + ( hpack + , hpackVersion + ) where + +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Char ( isDigit, isSpace ) +import qualified Hpack +import qualified Hpack.Config as Hpack +import Pantry.Types +import Path + ( Abs, Dir, Path, (), filename, parseRelFile, toFilePath ) +import Path.IO ( doesFileExist ) +import RIO +import RIO.Process + +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. Ignoring " + <> fromString (toFilePath hpackFile) + <> " in favor of the Cabal file.\n" + <> "Either please upgrade and try again or, if you want to use the " + <> fromString (toFilePath (filename hpackFile)) + <> " file instead of the Cabal file,\n" + <> "then please delete the Cabal file." + Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ + cabalFile + <> " was modified manually. Ignoring " + <> fromString (toFilePath hpackFile) + <> " in favor of the Cabal file.\n" + <> "If 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/int/Pantry/Internal.hs b/int/Pantry/Internal.hs new file mode 100644 --- /dev/null +++ b/int/Pantry/Internal.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Pantry.Internal + ( normalizeParents + , makeTarRelative + ) where + +import Control.Exception ( assert ) +import Data.Maybe ( fromMaybe ) +import qualified Data.Text as T + +-- | Like @System.FilePath.normalise@, however: +-- +-- * Only works on relative paths, absolute paths fail +-- +-- * Strips trailing slashes +-- +-- * Only works on forward slashes, even on Windows +-- +-- * Normalizes parent dirs @foo/../@ get stripped +-- +-- * Cannot begin with a parent directory (@../@) +-- +-- * Spelled like an American, sorry +normalizeParents :: + FilePath + -> Either String FilePath +normalizeParents "" = Left "empty file path" +normalizeParents ('/':_) = Left "absolute path" +normalizeParents ('.':'.':'/':_) = Left "absolute path" +normalizeParents fp = do + -- Strip a single trailing, but not multiple + let t0 = T.pack fp + t = fromMaybe t0 $ T.stripSuffix "/" t0 + case T.unsnoc t of + Just (_, '/') -> Left "multiple trailing slashes" + _ -> Right () + + let c1 = T.split (== '/') t + + case reverse c1 of + ".":_ -> Left "last component is a single dot" + _ -> Right () + + let c2 = filter (\x -> not (T.null x || x == ".")) c1 + + let loop [] routput = reverse routput + loop ("..":rest) (_:routput) = loop rest routput + loop (x:xs) routput = loop xs (x:routput) + + case loop c2 [] of + [] -> Left "no non-empty components" + c' -> Right $ T.unpack $ T.intercalate "/" c' + +-- | Following tar file rules (Unix file paths only), make the second file +-- relative to the first file. +makeTarRelative :: + FilePath -- ^ base file + -> FilePath -- ^ relative part + -> Either String FilePath +makeTarRelative _ ('/':_) = Left "absolute path found" +makeTarRelative base rel = + case reverse base of + [] -> Left "cannot have empty base" + '/':_ -> Left "base cannot be a directory" + _:rest -> Right $ + case dropWhile (/= '/') rest of + '/':rest' -> reverse rest' ++ '/' : rel + rest' -> assert (null rest') rel diff --git a/int/Pantry/SHA256.hs b/int/Pantry/SHA256.hs new file mode 100644 --- /dev/null +++ b/int/Pantry/SHA256.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides a data type ('SHA256') for efficient memory representation of a +-- sha-256 hash value, together with helper functions for converting to and from +-- that value. This module is intended to be imported qualified as @SHA256@. +-- +-- Some nomenclature: +-- +-- * Hashing calculates a new hash value from some input. @from@ takes a value +-- that represents an existing hash. +-- +-- * Raw means a raw binary representation of the hash value, without any hex +-- encoding. +-- +-- * Text always uses lower case hex encoding +-- +-- @since 0.1.0.0 +module Pantry.SHA256 + ( -- * Types + SHA256 + , SHA256Exception (..) + -- * Hashing + , hashFile + , hashBytes + , hashLazyBytes + , sinkHash + -- * Convert from a hash representation + , fromHexText + , fromHexBytes + , fromDigest + , fromRaw + -- * Convert to a hash representation + , toHexText + , toHexBytes + , toRaw + ) where + +import Conduit +import qualified Crypto.Hash as Hash ( Digest, SHA256, hash, hashlazy ) +import qualified Crypto.Hash.Conduit as Hash ( hashFile, sinkHash ) +import Data.Aeson +import qualified Data.ByteArray +import qualified Data.ByteArray.Encoding as Mem +import Data.StaticBytes + ( Bytes32, StaticBytesException, toStaticExact ) +import Database.Persist.Sql +import RIO +import qualified RIO.Text as T + +-- | 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 + +-- To support the Haskell Foundation's +-- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry +-- error messages generated by Pantry itself begin with an unique code in the +-- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999. +-- The numbers are selected at random, not in sequence. +instance Display SHA256Exception where + display (InvalidByteCount bs sbe) = + "Error: [S-161]\n" + <> "Invalid byte count creating a SHA256 from " + <> displayShow bs + <> ": " + <> displayShow sbe + display (InvalidHexBytes bs t) = + "Error: [S-165]\n" + <> "Invalid hex bytes creating a SHA256: " + <> displayShow bs + <> ": " + <> display t diff --git a/int/Pantry/SQLite.hs b/int/Pantry/SQLite.hs new file mode 100644 --- /dev/null +++ b/int/Pantry/SQLite.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Pantry.SQLite + ( Storage (..) + , initStorage + ) where + +import Control.Concurrent.Companion + ( Companion, onCompanionDone, withCompanion ) +import Database.Persist.Sqlite +import Pantry.Types + ( PantryException (MigrationFailure), Storage (..) ) +import Path ( Abs, File, Path, parent, toFilePath ) +import Path.IO ( ensureDir ) +import RIO hiding ( FilePath ) +import RIO.Orphans () +import System.FileLock + ( SharedExclusive (..), withFileLock, withTryFileLock ) + +initStorage :: + HasLogFunc env + => Text + -> Migration + -> Path Abs File -- ^ storage file + -> (Storage -> RIO env a) + -> RIO env a +initStorage description migration fp inner = do + ensureDir $ parent fp + + migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $ + withSqliteConnInfo (sqinfo True) $ runSqlConn $ + runMigrationSilent migration + forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig + + -- Make a single connection to the SQLite database and wrap it in an MVar for + -- the entire execution context. Previously we used a resource pool of size + -- 1, but (1) there's no advantage to that, and (2) it had a _very_ weird + -- interaction with Docker on OS X where when resource-pool's reaper would + -- trigger, it would somehow cause the Stack process inside the container to + -- die with a SIGBUS. Definitely an interesting thing worth following up + -- on... + withSqliteConnInfo (sqinfo False) $ \conn0 -> do + connVar <- newMVar conn0 + inner $ Storage + -- NOTE: Currently, we take a write lock on every action. This is + -- a bit heavyweight, but it avoids the SQLITE_BUSY errors + -- reported in + -- + -- completely. We can investigate more elegant solutions in the + -- future, such as separate read and write actions or introducing + -- smarter retry logic. + { withStorage_ = \action -> withMVar connVar $ \conn -> + withWriteLock (display description) fp $ + runSqlConn action conn + , withWriteLock_ = id + } + where + wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp) + + sqinfo isMigration + = set extraPragmas ["PRAGMA busy_timeout=2000;"] + $ set walEnabled False + + -- When doing a migration, we want to disable foreign key checking, since + -- the order in which tables are created by the migration scripts may not + -- respect foreign keys. The rest of the time: enforce those foreign keys. + $ set fkEnabled (not isMigration) + + $ mkSqliteConnectionInfo (fromString $ toFilePath fp) + +-- | Ensure that only one process is trying to write to the database at a time. +-- See https://github.com/commercialhaskell/stack/issues/4471 and comments +-- above. +withWriteLock :: + HasLogFunc env + => Utf8Builder -- ^ database description, for lock messages + -> Path Abs File -- ^ SQLite database file + -> RIO env a + -> RIO env a +withWriteLock desc dbFile inner = do + let lockFile = toFilePath dbFile ++ ".pantry-write-lock" + withRunInIO $ \run -> do + mres <- withTryFileLock lockFile Exclusive $ const $ run inner + case mres of + Just res -> pure res + Nothing -> do + let complainer :: Companion IO + complainer delay = run $ do + -- Wait five seconds before giving the first message to + -- avoid spamming the user for uninteresting file locks + delay $ 5 * 1000 * 1000 -- 5 seconds + logInfo $ + "Unable to get a write lock on the " + <> desc + <> " database, waiting..." + + -- Now loop printing a message every 1 minute + forever $ do + delay (60 * 1000 * 1000) -- 1 minute + `onCompanionDone` logInfo + ( "Acquired the " + <> desc + <> " database write lock" + ) + logWarn + ( "Still waiting on the " + <> desc + <> " database write lock..." + ) + withCompanion complainer $ \stopComplaining -> + withFileLock lockFile Exclusive $ const $ do + stopComplaining + run inner diff --git a/int/Pantry/Types.hs b/int/Pantry/Types.hs new file mode 100644 --- /dev/null +++ b/int/Pantry/Types.hs @@ -0,0 +1,3339 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Pantry.Types + ( PantryConfig (..) + , PackageIndexConfig (..) + , HackageSecurityConfig (..) + , defaultHackageSecurityConfig + , Storage (..) + , HasPantryConfig (..) + , BlobKey (..) + , PackageName + , Version + , PackageIdentifier (..) + , Revision (..) + , ModuleName + , CabalFileInfo (..) + , PrintWarnings (..) + , PackageNameP (..) + , VersionP (..) + , ModuleNameP (..) + , PackageIdentifierRevision (..) + , pirForHash + , FileType (..) + , BuildFile (..) + , FileSize (..) + , TreeEntry (..) + , SafeFilePath + , unSafeFilePath + , mkSafeFilePath + , safeFilePathToPath + , hpackSafeFilePath + , TreeKey (..) + , Tree (..) + , renderTree + , parseTree + , parseTreeM + , SHA256 + , Unresolved + , resolvePaths + , Package (..) + , PackageCabal (..) + , PHpack (..) + -- , PackageTarball (..) + , RawPackageLocation (..) + , PackageLocation (..) + , toRawPL + , RawPackageLocationImmutable (..) + , PackageLocationImmutable (..) + , toRawPLI + , RawArchive (..) + , Archive (..) + , toRawArchive + , Repo (..) + , AggregateRepo (..) + , SimpleRepo (..) + , toAggregateRepos + , rToSimpleRepo + , arToSimpleRepo + , RepoType (..) + , parsePackageIdentifier + , parsePackageName + , parsePackageNameThrowing + , parseFlagName + , parseVersion + , parseVersionThrowing + , packageIdentifierString + , packageNameString + , flagNameString + , versionString + , moduleNameString + , OptionalSubdirs (..) + , ArchiveLocation (..) + , RelFilePath (..) + , CabalString (..) + , toCabalStringMap + , unCabalStringMap + , parsePackageIdentifierRevision + , Mismatch (..) + , PantryException (..) + , FuzzyResults (..) + , ResolvedPath (..) + , HpackExecutable (..) + , WantedCompiler (..) + --, resolveSnapshotLocation + , snapshotLocation + , defaultSnapshotLocation + , SnapName (..) + , parseSnapName + , RawSnapshotLocation (..) + , SnapshotLocation (..) + , toRawSL + , parseHackageText + , parseRawSnapshotLocation + , RawSnapshotLayer (..) + , SnapshotLayer (..) + , toRawSnapshotLayer + , RawSnapshot (..) + , Snapshot (..) + , RawSnapshotPackage (..) + , SnapshotPackage (..) + , parseWantedCompiler + , RawPackageMetadata (..) + , PackageMetadata (..) + , toRawPM + , cabalFileName + , SnapshotCacheHash (..) + , getGlobalHintsFile + , bsToBlobKey + , warnMissingCabalFile + , connRDBMS + ) where + +import Casa.Client ( CasaRepoPrefix ) +import Database.Persist +import Database.Persist.Sql +#if MIN_VERSION_persistent(2, 13, 0) +import Database.Persist.SqlBackend.Internal ( connRDBMS ) +#endif +import Data.Aeson.Encoding.Internal ( unsafeToEncoding ) +import Data.Aeson.Types + ( FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..) + , Object, Parser, ToJSON (..), ToJSONKey (..) + , ToJSONKeyFunction (..), Value (..), (.=), object + , toJSONKeyText, withObject, withText + ) +import Data.Aeson.WarningParser + ( WarningParser, WithJSONWarnings, (..:), (..:?), (..!=) + , (.:), (...:?), jsonSubWarnings, jsonSubWarningsT + , noJSONWarnings, tellJSONField, withObjectWarnings + ) +import Data.ByteString.Builder + ( byteString, toLazyByteString, wordDec ) +import qualified Data.Conduit.Tar as Tar +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map ( mapKeysMonotonic ) +import Data.Text.Read ( decimal ) +import Distribution.CabalSpecVersion ( cabalSpecLatest ) +#if MIN_VERSION_Cabal(3,4,0) +import Distribution.CabalSpecVersion ( cabalSpecToVersionDigits ) +#else +import Distribution.CabalSpecVersion ( CabalSpecVersion (..) ) +#endif +import qualified Distribution.Compat.CharParsing as Parse +import Distribution.ModuleName ( ModuleName ) +import Distribution.PackageDescription + ( FlagName, GenericPackageDescription, unFlagName ) +import Distribution.Parsec + ( PError (..), PWarning (..), ParsecParser + , explicitEitherParsec, parsec, showPos + ) +import qualified Distribution.Pretty +import qualified Distribution.Text +import Distribution.Types.PackageId ( PackageIdentifier (..) ) +import Distribution.Types.PackageName + ( PackageName, mkPackageName, unPackageName ) +import Distribution.Types.Version ( Version, mkVersion, nullVersion ) +import Distribution.Types.VersionRange ( VersionRange ) +import qualified Hpack.Config as Hpack +import Network.HTTP.Client ( parseRequest ) +import Network.HTTP.Types ( Status, statusCode ) +import Pantry.SHA256 ( SHA256 ) +import qualified Pantry.SHA256 as SHA256 +import Path + ( Abs, Dir, File, Path, (), filename, parseRelFile + , toFilePath + ) +import Path.IO ( resolveDir, resolveFile ) +import qualified RIO.Set as Set +import RIO +import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL +import RIO.List ( groupBy, intersperse ) +import qualified RIO.Text as T +import RIO.Time ( Day, UTCTime, toGregorian ) +import qualified RIO.Map as Map +import RIO.PrettyPrint + ( bulletedList, fillSep, flow, hang, line, mkNarrativeList + , parens, string, style + ) +import RIO.PrettyPrint.Types ( Style (..) ) +import Text.PrettyPrint.Leijen.Extended ( Pretty (..), StyleDoc ) + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.KeyMap as HM +import qualified Data.Aeson.Key + +type AesonKey = Data.Aeson.Key.Key +#else +import qualified RIO.HashMap as HM + +type AesonKey = Text +#endif + +-- | Parsed tree with more information on the Haskell package it contains. +-- +-- @since 0.1.0.0 +data Package = Package + { packageTreeKey :: !TreeKey + -- ^ The 'TreeKey' containing this package. + -- + -- This is a hash of the binary representation of 'packageTree'. + -- + -- @since 0.1.0.0 + , packageTree :: !Tree + -- ^ The 'Tree' containing this package. + -- + -- @since 0.1.0.0 + , packageCabalEntry :: !PackageCabal + -- ^ Information on the cabal file inside this package. + -- + -- @since 0.1.0.0 + , packageIdent :: !PackageIdentifier + -- ^ The package name and version in this package. + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord) + +data PHpack = PHpack + { phOriginal :: !TreeEntry + -- ^ Original hpack file + , phGenerated :: !TreeEntry + -- ^ Generated Cabal file + , phVersion :: !Version + -- ^ Version of Hpack used + } + deriving (Show, Eq, Ord) + +data PackageCabal + = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file + | PCHpack !PHpack + deriving (Show, Eq, Ord) + +cabalFileName :: PackageName -> SafeFilePath +cabalFileName name = + case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of + Nothing -> error $ "cabalFileName: failed for " ++ show name + Just sfp -> sfp + +-- | The revision number of a package from Hackage, counting upwards from 0 (the +-- original cabal file). +-- +-- See caveats on 'CFIRevision'. +-- +-- @since 0.1.0.0 +newtype Revision = Revision Word + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql) + +-- | Represents a SQL database connection. This used to be a newtype wrapper +-- around a connection pool. However, when investigating +-- , it appeared that +-- holding a pool resulted in overly long write locks being held on the +-- database. As a result, we now abstract away whether a pool is used, and the +-- default implementation in "Pantry.Storage" does not use a pool. +data Storage = Storage + { withStorage_ :: + forall env a. HasLogFunc env + => ReaderT SqlBackend (RIO env) a + -> RIO env a + , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a + } + +-- | Configuration value used by the entire pantry package. Create one using +-- 'withPantryConfig' or 'withPantryConfig''. See also 'PantryApp' for a +-- convenience approach to using pantry. +-- +-- @since 0.1.0.0 +data PantryConfig = PantryConfig + { pcPackageIndex :: !PackageIndexConfig + , 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 + , pcCasaConfig :: !(Maybe (CasaRepoPrefix, Int)) + -- ^ Optionally, the Casa pull URL e.g. @https://casa.fpcomplete.com@ and + -- the maximum number of Casa keys to pull per request. + , pcSnapshotLocation :: SnapName -> RawSnapshotLocation + -- ^ The location of snapshot synonyms + } + +-- | Get the location of a snapshot synonym from the 'PantryConfig'. +-- +-- @since 0.5.0.0 +snapshotLocation :: + HasPantryConfig env + => SnapName + -> RIO env RawSnapshotLocation +snapshotLocation name = do + loc <- view $ pantryConfigL.to pcSnapshotLocation + pure $ loc name + +-- | Should we print warnings when loading a cabal file? +-- +-- @since 0.1.0.0 +data PrintWarnings = YesPrintWarnings | NoPrintWarnings + +-- | Wraps a value which potentially contains relative paths. Needs to be +-- provided with a base directory to resolve these paths. +-- +-- Unwrap this using 'resolvePaths'. +-- +-- @since 0.1.0.0 +newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) + deriving Functor + +instance Applicative Unresolved where + pure = Unresolved . const . pure + Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir + +-- | Resolve all of the file paths in an 'Unresolved' relative to the given +-- directory. +-- +-- @since 0.1.0.0 +resolvePaths :: + MonadIO m + => Maybe (Path Abs Dir) -- ^ directory to use for relative paths + -> Unresolved a + -> m a +resolvePaths mdir (Unresolved f) = liftIO (f mdir) + +-- | A combination of the relative path provided in a config file, together with +-- the resolved absolute path. +-- +-- @since 0.1.0.0 +data ResolvedPath t = ResolvedPath + { resolvedRelative :: !RelFilePath + -- ^ Original value parsed from a config file. + , resolvedAbsolute :: !(Path Abs t) + -- ^ Absolute path resolved against base directory loaded from. + } + deriving (Show, Eq, Generic, Ord) + +instance NFData (ResolvedPath t) + +-- | Location to load a package from. Can either be immutable (see +-- 'PackageLocationImmutable') or a local directory which is expected to change +-- over time. Raw version doesn't include exact package version (e.g. could +-- refer to the latest revision on Hackage) +-- +-- @since 0.1.0.0 +data RawPackageLocation + = RPLImmutable !RawPackageLocationImmutable + | RPLMutable !(ResolvedPath Dir) + deriving (Show, Eq, Generic) + +instance NFData RawPackageLocation + +-- | Location to load a package from. Can either be immutable (see +-- 'PackageLocationImmutable') or a local directory which is expected to change +-- over time. +-- +-- @since 0.1.0.0 +data PackageLocation + = PLImmutable !PackageLocationImmutable + | PLMutable !(ResolvedPath Dir) + deriving (Show, Eq, Generic) + +instance NFData PackageLocation + +instance Display PackageLocation where + display (PLImmutable loc) = display loc + display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp + +-- | Convert `PackageLocation` to its "raw" equivalent +-- +-- @since 0.1.0.0 +toRawPL :: PackageLocation -> RawPackageLocation +toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im) +toRawPL (PLMutable m) = RPLMutable m + +-- | Location for remote packages or archives assumed to be immutable. +-- as user specifies it i.e. not an exact location +-- +-- @since 0.1.0.0 +data RawPackageLocationImmutable + = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey) + | RPLIArchive !RawArchive !RawPackageMetadata + | RPLIRepo !Repo !RawPackageMetadata + deriving (Show, Eq, Ord, Generic) + +instance NFData RawPackageLocationImmutable + +instance Display RawPackageLocationImmutable where + display (RPLIHackage pir _tree) = display pir <> " (from Hackage)" + display (RPLIArchive archive _pm) = + "Archive from " <> display (raLocation archive) <> + (if T.null $ raSubdir archive + then mempty + else " in subdir " <> display (raSubdir archive)) + display (RPLIRepo repo _pm) = + "Repo from " <> display (repoUrl repo) <> + ", commit " <> display (repoCommit repo) <> + (if T.null $ repoSubdir repo + then mempty + else " in subdir " <> display (repoSubdir repo)) + +instance Pretty RawPackageLocationImmutable where + pretty (RPLIHackage pir _tree) = fillSep + [ fromString . T.unpack $ textDisplay pir + , parens (flow "from Hackage") + ] + pretty (RPLIArchive archive _pm) = fillSep + [ flow "Archive from" + , pretty (raLocation archive) + , if T.null $ raSubdir archive + then mempty + else fillSep + [ flow "in subdir" + , style Dir (fromString $ T.unpack (raSubdir archive)) + ] + ] + pretty (RPLIRepo repo _pm) = fillSep + [ flow "Repo from" + , style Url (fromString $ T.unpack (repoUrl repo)) <> "," + , "commit" + , fromString $ T.unpack (repoCommit repo) + , if T.null $ repoSubdir repo + then mempty + else fillSep + [ flow "in subdir" + , style Dir (fromString $ T.unpack (repoSubdir repo)) + ] + ] + +-- | Location for remote packages or archives assumed to be immutable. +-- +-- @since 0.1.0.0 +data PackageLocationImmutable + = PLIHackage !PackageIdentifier !BlobKey !TreeKey + | PLIArchive !Archive !PackageMetadata + | PLIRepo !Repo !PackageMetadata + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData PackageLocationImmutable + +instance Display PackageLocationImmutable where + display (PLIHackage ident _cabalHash _tree) = + fromString (packageNameString $ pkgName ident) <> " (from Hackage)" + display (PLIArchive archive _pm) = + "Archive from " <> display (archiveLocation archive) <> + (if T.null $ archiveSubdir archive + then mempty + else " in subdir " <> display (archiveSubdir archive)) + display (PLIRepo repo _pm) = + "Repo from " <> display (repoUrl repo) <> + ", commit " <> display (repoCommit repo) <> + (if T.null $ repoSubdir repo + then mempty + else " in subdir " <> display (repoSubdir repo)) + +instance ToJSON PackageLocationImmutable where + toJSON = toJSON . toRawPLI + +-- | Package identifier and revision with a specified cabal file hash +-- +-- @since 0.1.0.0 +pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision +pirForHash (PackageIdentifier name ver) (BlobKey sha size') = + let cfi = CFIHash sha (Just size') + in PackageIdentifierRevision name ver cfi + +-- | Convert `PackageLocationImmutable` to its "raw" equivalent +-- +-- @since 0.1.0.0 +toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable +toRawPLI (PLIHackage ident cfKey treeKey) = + RPLIHackage (pirForHash ident cfKey) (Just treeKey) +toRawPLI (PLIArchive archive pm) = + RPLIArchive (toRawArchive archive) (toRawPM pm) +toRawPLI (PLIRepo repo pm) = RPLIRepo repo (toRawPM pm) + +-- | A raw package archive, specified by a user, could have no +-- hash and file size information. +-- +-- @since 0.1.0.0 +data RawArchive = RawArchive + { raLocation :: !ArchiveLocation + -- ^ Location of the archive + -- + -- @since 0.1.0.0 + , raHash :: !(Maybe SHA256) + -- ^ Cryptographic hash of the archive file + -- + -- @since 0.1.0.0 + , raSize :: !(Maybe FileSize) + -- ^ Size of the archive file + -- + -- @since 0.1.0.0 + , raSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 + } + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData RawArchive + +-- | A package archive, could be from a URL or a local file path. Local file +-- path archives are assumed to be unchanging over time, and so are allowed in +-- custom snapshots. +-- +-- @since 0.1.0.0 +data Archive = Archive + { archiveLocation :: !ArchiveLocation + -- ^ Location of the archive + -- + -- @since 0.1.0.0 + , archiveHash :: !SHA256 + -- ^ Cryptographic hash of the archive file + -- + -- @since 0.1.0.0 + , archiveSize :: !FileSize + -- ^ Size of the archive file + -- + -- @since 0.1.0.0 + , archiveSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 + } + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData Archive + +-- | Convert archive to its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawArchive :: Archive -> RawArchive +toRawArchive archive = + RawArchive (archiveLocation archive) (Just $ archiveHash archive) + (Just $ archiveSize archive) (archiveSubdir archive) + +-- | The type of a source control repository. +-- +-- @since 0.1.0.0 +data RepoType = RepoGit | RepoHg + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData RepoType + +instance PersistField RepoType where + toPersistValue RepoGit = toPersistValue (1 :: Int32) + toPersistValue RepoHg = toPersistValue (2 :: Int32) + fromPersistValue v = do + i <- fromPersistValue v + case i :: Int32 of + 1 -> pure RepoGit + 2 -> pure RepoHg + _ -> Left $ fromString $ "Invalid RepoType: " ++ show i + +instance PersistFieldSql RepoType where + sqlType _ = SqlInt32 + +-- | Information on packages stored in a source control repository. +-- +-- @since 0.1.0.0 +data Repo = Repo + { repoUrl :: !Text + -- ^ Location of the repo + -- + -- @since 0.1.0.0 + , repoCommit :: !Text + -- ^ Commit to use from the repo. It's strongly recommended to use + -- a hash instead of a tag or branch name. + -- + -- @since 0.1.0.0 + , repoType :: !RepoType + -- ^ The type of the repo + -- + -- @since 0.1.0.0 + , repoSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 + } + deriving (Generic, Eq, Ord, Typeable) + +instance NFData Repo + +instance Show Repo where + show = T.unpack . utf8BuilderToText . display + +instance Display Repo where + display (Repo url commit typ subdir) = + (case typ of + RepoGit -> "Git" + RepoHg -> "Mercurial") <> + " repo at " <> + display url <> + ", commit " <> + display commit <> + (if T.null subdir + then mempty + else " in subdirectory " <> display subdir) + +rToSimpleRepo :: Repo -> SimpleRepo +rToSimpleRepo Repo {..} = SimpleRepo + { sRepoUrl = repoUrl + , sRepoCommit = repoCommit + , sRepoType = repoType + } + +data AggregateRepo = AggregateRepo + { aRepo :: !SimpleRepo + , aRepoSubdirs :: [(Text, RawPackageMetadata)] + } + deriving (Show, Generic, Eq, Ord, Typeable) + +-- | Group input repositories by non-subdir values. +toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo] +toAggregateRepos = mapMaybe toAggregateRepo . groupBy matchRepoExclSubdir + where + toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo + toAggregateRepo [] = Nothing + toAggregateRepo xs@((repo, _):_) = + Just $ AggregateRepo (rToSimpleRepo repo) (fmap (first repoSubdir) xs) + + matchRepoExclSubdir x1 x2 = + let (Repo url1 commit1 type1 _, _) = x1 + (Repo url2 commit2 type2 _, _) = x2 + in (url1, commit1, type1) == (url2, commit2, type2) + +arToSimpleRepo :: AggregateRepo -> SimpleRepo +arToSimpleRepo AggregateRepo {..} = aRepo + +-- | Repository without subdirectory information. +-- +-- @since 0.5.3 +data SimpleRepo = SimpleRepo + { sRepoUrl :: !Text + , sRepoCommit :: !Text + , sRepoType :: !RepoType + } + deriving (Show, Generic, Eq, Ord, Typeable) + +instance Display SimpleRepo where + display (SimpleRepo url commit typ) = + (case typ of + RepoGit -> "Git" + RepoHg -> "Mercurial") <> + " repo at " <> + display url <> + ", commit " <> + display commit + +-- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains +-- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". +newtype GitHubRepo = GitHubRepo Text + +instance FromJSON GitHubRepo where + parseJSON = withText "GitHubRepo" $ \s -> do + case T.split (== '/') s of + [x, y] | not (T.null x || T.null y) -> pure (GitHubRepo s) + _ -> fail "expecting \"user/repo\"" + +-- | Configuration to securely download package metadata and contents. For most +-- purposes, you'll want to use the default Hackage settings via +-- @defaultPackageIndexConfig@. +-- +-- /NOTE/ It's highly recommended to only use the official Hackage +-- server or a mirror. See +-- . +-- +-- @since 0.6.0 +data PackageIndexConfig = PackageIndexConfig + { picDownloadPrefix :: !Text + , picHackageSecurityConfig :: !HackageSecurityConfig + } + deriving Show + +-- | If the @hackage-security@ key is absent from the JSON object, assigns +-- default value 'defaultHackageSecurityConfig'. +-- +-- @since 0.6.0 +instance FromJSON (WithJSONWarnings PackageIndexConfig) where + parseJSON = withObjectWarnings "PackageIndexConfig" $ \o -> do + picDownloadPrefix <- o ..: "download-prefix" + picHackageSecurityConfig <- jsonSubWarnings $ + o ..:? "hackage-security" ..!= noJSONWarnings defaultHackageSecurityConfig + pure PackageIndexConfig {..} + +-- | Default 'HackageSecurityConfig' value using the official Hackage server. +-- The value of the 'hscIgnoreExpiry' field is 'True'. +-- +-- @since 0.7.0 +defaultHackageSecurityConfig :: HackageSecurityConfig +defaultHackageSecurityConfig = HackageSecurityConfig + { hscKeyIds = + -- Key owners and public keys are provided as a convenience to readers. + -- The canonical source for this mapping data is the hackage-root-keys + -- repository and Hackage's root.json file. + -- + -- Links: + -- * https://github.com/haskell-infra/hackage-root-keys + -- * https://hackage.haskell.org/root.json + -- Please consult root.json on Hackage to map key IDs to public keys, + -- and the hackage-root-keys repository to map public keys to their + -- owners. + [ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=) + "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" + , -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=) + "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" + , -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=) + "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" + , -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=) + "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" + , -- Mathieu Boespflug (ydN1nGGQ79K1Q0nN+ul+Ln8MxikTB95w0YdGd3v3kmg=) + "be75553f3c7ba1dbe298da81f1d1b05c9d39dd8ed2616c9bddf1525ca8c03e48" + , -- Joachim Breitner (5iUgwqZCWrCJktqMx0bBMIuoIyT4A1RYGozzchRN9rA=) + "d26e46f3b631aae1433b89379a6c68bd417eb5d1c408f0643dcc07757fece522" + ] + , hscKeyThreshold = 3 + , hscIgnoreExpiry = True + } + +-- | Configuration for Hackage Security to securely download package metadata +-- and contents. 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.6.0 +data HackageSecurityConfig = HackageSecurityConfig + { hscKeyIds :: ![Text] + , hscKeyThreshold :: !Int + , hscIgnoreExpiry :: !Bool + } + deriving Show + +-- | If the @ignore-expiry@ key is absent from the JSON object, assigns default +-- value 'True'. +-- +-- @since 0.1.1.0 +instance FromJSON (WithJSONWarnings HackageSecurityConfig) where + parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o -> do + hscKeyIds <- o ..: "keyids" + hscKeyThreshold <- o ..: "key-threshold" + hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True + pure HackageSecurityConfig {..} + +-- | An environment which contains a 'PantryConfig'. +-- +-- @since 0.1.0.0 +class HasPantryConfig env where + -- | Lens to get or set the 'PantryConfig' + -- + -- @since 0.1.0.0 + pantryConfigL :: Lens' env PantryConfig + + +-- | File size in bytes +-- +-- @since 0.1.0.0 +newtype FileSize = FileSize Word + deriving ( Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData + , PersistField, PersistFieldSql, ToJSON, FromJSON + ) + +-- | A key for looking up a blob, which combines the SHA256 hash of the contents +-- and the file size. +-- +-- The file size may seem redundant with the hash. However, it is necessary for +-- safely downloading blobs from an untrusted source. See +-- . +-- +-- @since 0.1.0.0 +data BlobKey = BlobKey !SHA256 !FileSize + deriving (Eq, Ord, Typeable, Generic) + +instance NFData BlobKey + +instance Show BlobKey where + show = T.unpack . utf8BuilderToText . display + +instance Display BlobKey where + display (BlobKey sha size') = display sha <> "," <> display size' + +blobKeyPairs :: BlobKey -> [(AesonKey, Value)] +blobKeyPairs (BlobKey sha size') = + [ "sha256" .= sha + , "size" .= size' + ] + +instance ToJSON BlobKey where + toJSON = object . blobKeyPairs + +instance FromJSON BlobKey where + parseJSON = withObject "BlobKey" $ \o -> BlobKey + <$> o .: "sha256" + <*> o .: "size" + +newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } + deriving (Eq, Ord, Show, Read, NFData) + +instance Display PackageNameP where + display = fromString . packageNameString . unPackageNameP + +instance PersistField PackageNameP where + toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn + fromPersistValue v = do + str <- fromPersistValue v + case parsePackageName str of + Nothing -> Left $ "Invalid package name: " <> T.pack str + Just pn -> Right $ PackageNameP pn + +instance PersistFieldSql PackageNameP where + sqlType _ = SqlString + +instance ToJSON PackageNameP where + toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn + +instance FromJSON PackageNameP where + parseJSON = + withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack + +instance ToJSONKey PackageNameP where + toJSONKey = + ToJSONKeyText + (fromString . packageNameString . unPackageNameP) + (unsafeToEncoding . getUtf8Builder . display) + +instance FromJSONKey PackageNameP where + fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack + +newtype VersionP = VersionP { unVersionP :: Version } + deriving (Eq, Ord, Show, Read, NFData) + +instance PersistField VersionP where + toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v + fromPersistValue v = do + str <- fromPersistValue v + case parseVersion str of + Nothing -> Left $ "Invalid version number: " <> T.pack str + Just ver -> Right $ VersionP ver + +instance PersistFieldSql VersionP where + sqlType _ = SqlString + +instance Display VersionP where + display (VersionP v) = fromString $ versionString v + +instance ToJSON VersionP where + toJSON (VersionP v) = String $ T.pack $ versionString v + +instance FromJSON VersionP where + parseJSON = + withText "VersionP" $ + either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack + +newtype ModuleNameP = ModuleNameP + { unModuleNameP :: ModuleName + } + deriving (Eq, Ord, Show, NFData) + +instance Display ModuleNameP where + display = fromString . moduleNameString . unModuleNameP + +instance PersistField ModuleNameP where + toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn + fromPersistValue v = do + str <- fromPersistValue v + case parseModuleName str of + Nothing -> Left $ "Invalid module name: " <> T.pack str + Just pn -> Right $ ModuleNameP pn + +instance PersistFieldSql ModuleNameP where + sqlType _ = SqlString + +-- | How to choose a cabal file for a package from Hackage. This is to work with +-- Hackage cabal file revisions, which makes @PackageIdentifier@ insufficient +-- for specifying a package from Hackage. +-- +-- @since 0.1.0.0 +data CabalFileInfo + = CFILatest + -- ^ Take the latest revision of the cabal file available. This + -- isn't reproducible at all, but the running assumption (not + -- necessarily true) is that cabal file revisions do not change + -- semantics of the build. + -- + -- @since 0.1.0.0 + | CFIHash !SHA256 !(Maybe FileSize) + -- ^ Identify by contents of the cabal file itself. Only reason for + -- @Maybe@ on @FileSize@ is for compatibility with input that + -- doesn't include the file size. + -- + -- @since 0.1.0.0 + | CFIRevision !Revision + -- ^ Identify by revision number, with 0 being the original and + -- counting upward. This relies on Hackage providing consistent + -- versioning. @CFIHash@ should be preferred wherever possible for + -- reproducibility. + -- + -- @since 0.1.0.0 + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData CabalFileInfo + +instance Hashable CabalFileInfo + +instance Display CabalFileInfo where + display CFILatest = mempty + display (CFIHash hash' msize) = + "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize + display (CFIRevision rev) = "@rev:" <> display rev + +-- | A full specification for a package from Hackage, including the package +-- name, version, and how to load up the correct cabal file revision. +-- +-- @since 0.1.0.0 +data PackageIdentifierRevision + = PackageIdentifierRevision !PackageName !Version !CabalFileInfo + deriving (Generic, Eq, Ord, Typeable) + +instance NFData PackageIdentifierRevision + +instance Show PackageIdentifierRevision where + show = T.unpack . utf8BuilderToText . display + +instance Display PackageIdentifierRevision where + display (PackageIdentifierRevision name version cfi) = + fromString (packageNameString name) + <> "-" + <> fromString (versionString version) + <> display cfi + +instance ToJSON PackageIdentifierRevision where + toJSON = toJSON . utf8BuilderToText . display + +instance FromJSON PackageIdentifierRevision where + parseJSON = withText "PackageIdentifierRevision" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure pir + +-- | Parse a hackage text. +-- +-- @since 0.1.0.0 +parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) +parseHackageText t = + either (\x -> error (show x) $ const $ Left $ PackageIdentifierRevisionParseFail t) Right $ + explicitEitherParsec (hackageTextParsec <* Parse.eof) $ + T.unpack t + +hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey) +hackageTextParsec = do + ident <- packageIdentifierParsec + _ <- Parse.string "@sha256:" + + shaT <- Parse.munch (/= ',') + sha <- either (const mzero) pure $ SHA256.fromHexText $ fromString shaT + + _ <- Parse.char ',' + size' <- Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't + pure (ident, BlobKey sha (FileSize size')) + +splitColon :: Text -> Maybe (Text, Text) +splitColon t' = + let (x, y) = T.break (== ':') t' + in (x, ) <$> T.stripPrefix ":" y + +-- | Parse a 'PackageIdentifierRevision' +-- +-- @since 0.1.0.0 +parsePackageIdentifierRevision :: + Text + -> Either PantryException PackageIdentifierRevision +parsePackageIdentifierRevision t = + maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do + let (identT, cfiT) = T.break (== '@') t + PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT + cfi <- + case splitColon cfiT of + Just ("@sha256", shaSizeT) -> do + let (shaT, sizeT) = T.break (== ',') shaSizeT + sha <- either (const Nothing) Just $ SHA256.fromHexText shaT + msize <- + case T.stripPrefix "," sizeT of + Nothing -> Just Nothing + Just sizeT' -> + case decimal sizeT' of + Right (size', "") -> Just $ Just $ FileSize size' + _ -> Nothing + pure $ CFIHash sha msize + Just ("@rev", revT) -> + case decimal revT of + Right (rev, "") -> pure $ CFIRevision $ Revision rev + _ -> Nothing + Nothing -> pure CFILatest + _ -> Nothing + pure $ PackageIdentifierRevision name version cfi + +data Mismatch a = Mismatch + { mismatchExpected :: !a + , mismatchActual :: !a + } + +-- | Things that can go wrong in pantry. Note two things: +-- +-- * Many other exception types may be thrown from underlying libraries. Pantry +-- does not attempt to wrap these underlying exceptions. +-- +-- * We may add more constructors to this data type in minor version bumps of +-- pantry. This technically breaks the PVP. You should not be writing pattern +-- matches against this type that expect total matching. +-- +-- @since 0.1.0.0 +data PantryException + = PackageIdentifierRevisionParseFail !Text + | InvalidCabalFile + !(Either RawPackageLocationImmutable (Path Abs File)) + !(Maybe Version) + ![PError] + ![PWarning] + | TreeWithoutCabalFile !RawPackageLocationImmutable + | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath] + | MismatchedCabalName !(Path Abs File) !PackageName + | NoLocalPackageDirFound !(Path Abs Dir) + | NoCabalFileFound !(Path Abs Dir) + | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] + | InvalidWantedCompiler !Text + | InvalidSnapshotLocation !(Path Abs Dir) !Text + | InvalidOverrideCompiler !WantedCompiler !WantedCompiler + | InvalidFilePathSnapshot !Text + | InvalidSnapshot !RawSnapshotLocation !SomeException + | MismatchedPackageMetadata + !RawPackageLocationImmutable + !RawPackageMetadata + !(Maybe TreeKey) + !PackageIdentifier + | Non200ResponseStatus !Status + | InvalidBlobKey !(Mismatch BlobKey) + | Couldn'tParseSnapshot !RawSnapshotLocation !String + | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName + | DownloadInvalidSHA256 !Text !(Mismatch SHA256) + | DownloadInvalidSize !Text !(Mismatch FileSize) + | DownloadTooLarge !Text !(Mismatch FileSize) + -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is + -- a lower bound on the size from the server. + | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256) + | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize) + | UnknownArchiveType !ArchiveLocation + | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType + | UnsupportedTarball !ArchiveLocation !Text + | NoHackageCryptographicHash !PackageIdentifier + | FailedToCloneRepo !SimpleRepo + | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey + | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata + | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32) + | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults + | CannotCompleteRepoNonSHA1 !Repo + | MutablePackageLocationFromUrl !Text + | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) + | PackageNameParseFail !Text + | PackageVersionParseFail !Text + | InvalidCabalFilePath !(Path Abs File) + | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])] + | MigrationFailure !Text !(Path Abs File) !SomeException + | NoCasaConfig + | InvalidTreeFromCasa !BlobKey !ByteString + | ParseSnapNameException !Text + | HpackLibraryException !(Path Abs File) !String + | HpackExeException !FilePath !(Path Abs Dir) !SomeException + deriving Typeable + +instance Exception PantryException where + +instance Show PantryException where + show = T.unpack . utf8BuilderToText . display + +-- To support the Haskell Foundation's +-- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry +-- error messages generated by Pantry itself begin with an unique code in the +-- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999. +-- The numbers are selected at random, not in sequence. +-- +-- Prettier versions of these error messages are also provided. See the instance +-- of Pretty. +instance Display PantryException where + display NoCasaConfig = + "Error: [S-889]\n" + <> "The Pantry configuration has no Casa configuration." + display (InvalidTreeFromCasa blobKey _bs) = + "Error: [S-258]\n" + <> "Invalid tree from casa: " + <> display blobKey + display (PackageIdentifierRevisionParseFail text) = + "Error: [S-360]\n" + <> "Invalid package identifier (with optional revision): " + <> display text + display (InvalidCabalFile loc mversion errs warnings) = + "Error: [S-242]\n" + <> "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) = + "Error: [S-654]\n" + <> "No cabal file found for " + <> display pl + display (TreeWithMultipleCabalFiles pl sfps) = + "Error: [S-500]\n" + <> "Multiple cabal files found for " + <> display pl + <> ": " + <> fold (intersperse ", " (map display sfps)) + display (MismatchedCabalName fp name) = + "Error: [S-910]\n" + <> "The Cabal file:\n" + <> fromString (toFilePath fp) + <> "\nis not named after the package that it defines.\n" + <> "Please rename the file to: " + <> fromString (packageNameString name) + <> ".cabal\n" + <> "Hackage rejects packages where the first part of the Cabal file name " + <> "is not the package name." + display (NoLocalPackageDirFound dir) = + "Error: [S-395]\n" + <> "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 such directory could be found. If, alternatively, a package\n" + <> "in the package index was intended, its name and version must be\n" + <> "specified as an extra-dep." + display (NoCabalFileFound dir) = + "Error: [S-636]\n" + <> "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) = + "Error: [S-368]\n" + <> "Multiple .cabal files found in directory " + <> fromString (toFilePath dir) + <> ":\n" + <> fold + ( intersperse + "\n" + (map (\x -> "- " <> fromString (toFilePath (filename x))) files) + ) + display (InvalidWantedCompiler t) = + "Error: [S-204]\n" + <> "Invalid wanted compiler: " + <> display t + display (InvalidSnapshotLocation dir t) = + "Error: [S-935]\n" + <> "Invalid snapshot location " + <> displayShow t + <> " relative to directory " + <> displayShow (toFilePath dir) + display (InvalidOverrideCompiler x y) = + "Error: [S-287]\n" + <> "Specified compiler for a resolver (" + <> display x + <> "), but also specified an override compiler (" + <> display y + <> ")" + display (InvalidFilePathSnapshot t) = + "Error: [S-617]\n" + <> "Specified snapshot as file path with " + <> displayShow t + <> ", but not reading from a local file" + display (InvalidSnapshot loc err) = + "Error: [S-775]\n" + <> "Exception while reading snapshot from " + <> display loc + <> ":\n" + <> displayShow err + display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = + "Error: [S-427]\n" + <> "Mismatched package metadata for " + <> display loc + <> "\nFound: " + <> fromString (packageIdentifierString foundIdent) + <> ( case mtreeKey of + Nothing -> mempty + Just treeKey -> " with tree " <> display treeKey + ) + <> "\nExpected: " + <> display pm + display (Non200ResponseStatus status) = + "Error: [S-571]\n" + <> "Unexpected non-200 HTTP status code: " + <> displayShow (statusCode status) + display (InvalidBlobKey Mismatch{..}) = + "Error: [S-236]\n" + <> "Invalid blob key found, expected: " + <> display mismatchExpected + <> ", actual: " + <> display mismatchActual + display (Couldn'tParseSnapshot sl err) = + "Error: [S-645]\n" + <> "Couldn't parse snapshot from " + <> display sl + <> ": " + <> fromString err + display (WrongCabalFileName pl sfp name) = + "Error: [S-575]\n" + <> "Wrong cabal file name for package " + <> display pl + <> "\nThe cabal file is named " + <> display sfp + <> ", but package name is " + <> fromString (packageNameString name) + <> "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" + display (DownloadInvalidSHA256 url Mismatch {..}) = + "Error: [S-394]\n" + <> "Mismatched SHA256 hash from " + <> display url + <> "\nExpected: " + <> display mismatchExpected + <> "\nActual: " + <> display mismatchActual + display (DownloadInvalidSize url Mismatch {..}) = + "Error: [S-401]\n" + <> "Mismatched download size from " + <> display url + <> "\nExpected: " + <> display mismatchExpected + <> "\nActual: " + <> display mismatchActual + display (DownloadTooLarge url Mismatch {..}) = + "Error: [S-113]\n" + <> "Download from " + <> display url + <> " was too large.\n" + <> "Expected: " + <> display mismatchExpected + <> ", stopped after receiving: " + <> display mismatchActual + display (LocalInvalidSHA256 path Mismatch {..}) = + "Error: [S-834]\n" + <> "Mismatched SHA256 hash from " + <> fromString (toFilePath path) + <> "\nExpected: " + <> display mismatchExpected + <> "\nActual: " + <> display mismatchActual + display (LocalInvalidSize path Mismatch {..}) = + "Error: [S-713]\n" + <> "Mismatched file size from " + <> fromString (toFilePath path) + <> "\nExpected: " + <> display mismatchExpected + <> "\nActual: " + <> display mismatchActual + display (UnknownArchiveType loc) = + "Error: [S-372]\n" + <> "Unable to determine archive type of: " + <> display loc + display (InvalidTarFileType loc fp x) = + "Error: [S-950]\n" + <> "Unsupported tar file type in archive " + <> display loc + <> " at file " + <> fromString fp + <> ": " + <> displayShow x + display (UnsupportedTarball loc err) = + "Error: [S-760]\n" + <> "Unsupported tarball from " + <> display loc + <> ": " + <> display err + display (NoHackageCryptographicHash ident) = + "Error: [S-922]\n" + <> "No cryptographic hash found for Hackage package " + <> fromString (packageIdentifierString ident) + display (FailedToCloneRepo repo) = + "Error: [S-109]\n" + <> "Failed to clone repo " + <> display repo + display (TreeReferencesMissingBlob loc sfp key) = + "Error: [S-237]\n" + <> "The package " + <> display loc + <> " needs blob " + <> display key + <> " for file path " + <> display sfp + <> ", but the blob is not available" + display (CompletePackageMetadataMismatch loc pm) = + "Error: [S-984]\n" + <> "When completing package metadata for " + <> display loc + <> ", some values changed in the new package metadata: " + <> display pm + display (CRC32Mismatch loc fp Mismatch {..}) = + "Error: [S-607]\n" + <> "CRC32 mismatch in ZIP file from " + <> display loc + <> " on internal file " + <> fromString fp + <> "\nExpected: " + <> display mismatchExpected + <> "\nActual: " + <> display mismatchActual + display (UnknownHackagePackage pir fuzzy) = + "Error: [S-476]\n" + <> "Could not find " + <> display pir + <> " on Hackage" + <> displayFuzzy fuzzy + display (CannotCompleteRepoNonSHA1 repo) = + "Error: [S-112]\n" + <> "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " + <> display repo + display (MutablePackageLocationFromUrl t) = + "Error: [S-321]\n" + <> "Cannot refer to a mutable package location from a URL: " + <> display t + display (MismatchedCabalFileForHackage pir Mismatch{..}) = + "Error: [S-377]\n" + <> "When processing cabal file for Hackage package " + <> display pir + <> ":\nMismatched package identifier." + <> "\nExpected: " + <> fromString (packageIdentifierString mismatchExpected) + <> "\nActual: " + <> fromString (packageIdentifierString mismatchActual) + display (PackageNameParseFail t) = + "Error: [S-580]\n" + <> "Invalid package name: " + <> display t + display (PackageVersionParseFail t) = + "Error: [S-479]\n" + <> "Invalid version: " + <> display t + display (InvalidCabalFilePath fp) = + "Error: [S-824]\n" + <> "File path contains a name which is not a valid package name: " + <> fromString (toFilePath fp) + display (DuplicatePackageNames source pairs') = + "Error: [S-674]\n" + <> "Duplicate package names (" + <> source + <> "):\n" + <> foldMap + ( \(name, locs) -> + fromString (packageNameString name) + <> ":\n" + <> foldMap (\loc -> "- " <> display loc <> "\n") locs + ) + pairs' + display (MigrationFailure desc fp err) = + "Error: [S-536]\n" + <> "Encountered error while migrating database " + <> display desc + <> "\nlocated at " + <> fromString (toFilePath fp) + <> ":" + <> "\n " + <> displayShow err + display (ParseSnapNameException t) = + "Error: [S-994]\n" + <> "Invalid snapshot name: " + <> display t + display (HpackLibraryException file err) = + "Error: [S-305]\n" + <> "Failed to generate a Cabal file using the Hpack library on file:\n" + <> fromString (toFilePath file) + <> "\n\n" + <> "The error encountered was:\n\n" + <> fromString err + display (HpackExeException fp dir err) = + "Error: [S-720]\n" + <> "Failed to generate a Cabal file using the Hpack executable:\n" + <> fromString fp + <> "in directory: " + <> fromString (toFilePath dir) + <> "\n\n" + <> "The error encountered was:\n\n" + <> fromString (show err) + +-- See also the instance of Display. Although prettier, these messages are +-- intended to be substantively the same as the corresponding 'black and white' +-- versions. +instance Pretty PantryException where + pretty NoCasaConfig = + "[S-889]" + <> line + <> flow "The Pantry configuration has no Casa configuration." + pretty (InvalidTreeFromCasa blobKey _bs) = + "[S-258]" + <> line + <> fillSep + [ flow "Invalid tree from casa:" + , fromString . T.unpack $ textDisplay blobKey + ] + pretty (PackageIdentifierRevisionParseFail text) = + "[S-360]" + <> line + <> fillSep + [ flow "Invalid package identifier (with optional revision):" + , fromString $ T.unpack text + ] + pretty (InvalidCabalFile loc mversion errs warnings) = + "[S-242]" + <> line + <> fillSep + [ flow "Unable to parse Cabal file from package" + , either pretty pretty loc <> ":" + ] + <> line + <> bulletedList + ( map (\(PError pos msg) -> fillSep + [ fromString (showPos pos) <> ":" + , fromString msg + ]) + errs + ) + <> line + <> bulletedList + ( map (\(PWarning _ pos msg) -> fillSep + [ fromString (showPos pos) <> ":" + , fromString msg + ]) + warnings + ) + <> ( case mversion of + Just version | version > cabalSpecLatestVersion -> + line + <> fillSep + [ flow "The Cabal file uses the Cabal specification version" + , style Current (fromString $ versionString version) <> "," + , flow "but we only support up to version" + , fromString (versionString cabalSpecLatestVersion) <> "." + , flow "Recommended action: upgrade your build tool" + , parens (fillSep + [ "e.g." + , style Shell (flow "stack upgrade") + ]) <> "." + ] + _ -> mempty + ) + pretty (TreeWithoutCabalFile loc) = + "[S-654]" + <> line + <> fillSep + [ flow "No Cabal file found for" + , pretty loc <> "." + ] + pretty (TreeWithMultipleCabalFiles loc sfps) = + "[S-500]" + <> line + <> fillSep + ( flow "Multiple Cabal files found for" + : (pretty loc <> ":") + : mkNarrativeList (Just File) False + (map (fromString . T.unpack . textDisplay) sfps :: [StyleDoc]) + ) + pretty (MismatchedCabalName fp name) = + "[S-910]" + <> line + <> fillSep + [ flow "The Cabal file" + , pretty fp + , flow "is not named after the package that it defines. Please rename" + , flow "the file to" + , style File (fromString $ packageNameString name <> ".cabal") <> "." + , flow "Hackage rejects packages where the first part of the Cabal" + , flow "file name is not the package name." + ] + pretty (NoLocalPackageDirFound dir) = + "[S-395]" + <> line + <> fillSep + [ flow "Stack looks for packages in the directories configured in the" + , style Shell "packages" + , "and" + , style Shell "extra-deps" + , flow "fields defined in your" + , style File "stack.yaml" <> "." + , flow "The current entry points to" + , pretty dir + , flow "but no such directory could be found. If, alternatively, a" + , flow "package in the package index was intended, its name and" + , flow "version must be specified as an extra-dep." + ] + pretty (NoCabalFileFound dir) = + "[S-636]" + <> line + <> fillSep + [ flow "Stack looks for packages in the directories configured in the" + , style Shell "packages" + , "and" + , style Shell "extra-deps" + , flow "fields defined in your" + , style File "stack.yaml" <> "." + , flow "The current entry points to" + , pretty dir + , flow "but no Cabal file or" + , style File "package.yaml" + , flow "could be found there." + ] + pretty (MultipleCabalFilesFound dir files) = + "[S-368]" + <> line + <> fillSep + ( flow "Multiple Cabal files found in directory" + : (pretty dir <> ":") + : mkNarrativeList (Just File) False + (map (pretty . filename) files) + ) + pretty (InvalidWantedCompiler t) = + "[S-204]" + <> line + <> fillSep + [ flow "Invalid wanted compiler:" + , style Current (fromString $ T.unpack t) <> "." + ] + pretty (InvalidSnapshotLocation dir t) = + "[S-935]" + <> line + <> fillSep + [ flow "Invalid snapshot location" + , style Current (fromString $ T.unpack t) + , flow "relative to directory" + , pretty dir <> "." + ] + pretty (InvalidOverrideCompiler x y) = + "[S-287]" + <> line + <> fillSep + [ flow "Specified compiler for a resolver" + , parens (style Shell (fromString . T.unpack $ textDisplay x)) + , flow "but also specified an override compiler" + , parens (style Shell (fromString . T.unpack $ textDisplay y)) <> "." + ] + pretty (InvalidFilePathSnapshot t) = + "[S-617]" + <> line + <> fillSep + [ flow "Specified snapshot as file path with" + , style File (fromString $ T.unpack t) <> "," + , flow "but not reading from a local file." + ] + pretty (InvalidSnapshot loc err) = + "[S-775]" + <> line + <> fillSep + [ flow "Exception while reading snapshot from" + , pretty loc <> ":" + ] + <> blankLine + <> string (displayException err) + pretty (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = + "[S-427]" + <> line + <> fillSep + [ flow "Mismatched package metadata for" + , pretty loc <> "." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , let t = textDisplay pm + in if T.null t + then "nothing." + else fromString $ T.unpack t <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Found: " + , fromString $ packageIdentifierString foundIdent <> case mtreeKey of + Nothing -> "." + _ -> mempty + , case mtreeKey of + Nothing -> mempty + Just treeKey -> fillSep + [ "with tree" + , fromString . T.unpack $ textDisplay treeKey <> "." + ] + ]) + pretty (Non200ResponseStatus status) = + "[S-571]" + <> line + <> fillSep + [ flow "Unexpected non-200 HTTP status code:" + , (fromString . show $ statusCode status) <> "." + ] + pretty (InvalidBlobKey Mismatch{..}) = + "[S-236]" + <> line + <> fillSep + [ flow "Invalid blob key found, expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "," + , "actual:" + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ] + pretty (Couldn'tParseSnapshot sl err) = + "[S-645]" + <> line + <> fillSep + [ flow "Couldn't parse snapshot from" + , pretty sl <> ":" + ] + <> blankLine + <> string err + pretty (WrongCabalFileName loc sfp name) = + "[S-575]" + <> line + <> fillSep + [ flow "Wrong Cabal file name for package" + , pretty loc <> "." + , flow "The Cabal file is named" + , style File (fromString . T.unpack $ textDisplay sfp) <> "," + , flow "but package name is" + , fromString (packageNameString name) <> "." + , flow "For more information, see" + , style Url "https://github.com/commercialhaskell/stack/issues/317" + , "and" + , style Url "https://github.com/commercialhaskell/stack/issues/895" <> "." + ] + pretty (DownloadInvalidSHA256 url Mismatch {..}) = + "[S-394]" + <> line + <> fillSep + [ flow "Mismatched SHA256 hash from" + , style Url (fromString $ T.unpack url) <> "." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ]) + pretty (DownloadInvalidSize url Mismatch {..}) = + "[S-401]" + <> line + <> fillSep + [ flow "Mismatched download size from" + , style Url (fromString $ T.unpack url) <> "." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ]) + pretty (DownloadTooLarge url Mismatch {..}) = + "[S-113]" + <> line + <> fillSep + [ flow "Download from" + , style Url (fromString $ T.unpack url) + , flow "was too large. Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "," + , flow "stopped after receiving:" + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ] + pretty (LocalInvalidSHA256 path Mismatch {..}) = + "[S-834]" + <> line + <> fillSep + [ flow "Mismatched SHA256 hash from" + , pretty path <> "." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ]) + pretty (LocalInvalidSize path Mismatch {..}) = + "[S-713]" + <> line + <> fillSep + [ flow "Mismatched file size from" + , pretty path <> "." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ]) + pretty (UnknownArchiveType loc) = + "[S-372]" + <> line + <> fillSep + [ flow "Unable to determine archive type of:" + , pretty loc <> "." + ] + pretty (InvalidTarFileType loc fp x) = + "[S-950]" + <> line + <> fillSep + [ flow "Unsupported tar file type in archive" + , pretty loc + , flow "at file" + , style File (fromString fp) <> ":" + , fromString $ show x <> "." + ] + pretty (UnsupportedTarball loc err) = + "[S-760]" + <> line + <> fillSep + [ flow "Unsupported tarball from" + , pretty loc <> ":" + ] + <> blankLine + <> string (T.unpack err) + pretty (NoHackageCryptographicHash ident) = + "[S-922]" + <> line + <> fillSep + [ flow "No cryptographic hash found for Hackage package" + , fromString (packageIdentifierString ident) <> "." + ] + pretty (FailedToCloneRepo repo) = + "[S-109]" + <> line + <> fillSep + [ flow "Failed to clone repository" + , fromString . T.unpack $ textDisplay repo + ] + pretty (TreeReferencesMissingBlob loc sfp key) = + "[S-237]" + <> line + <> fillSep + [ flow "The package" + , pretty loc + , flow "needs blob" + , fromString . T.unpack $ textDisplay key + , flow "for file path" + , style File (fromString . T.unpack $ textDisplay sfp) <> "," + , flow "but the blob is not available." + ] + pretty (CompletePackageMetadataMismatch loc pm) = + "[S-984]" + <> line + <> fillSep + [ flow "When completing package metadata for" + , pretty loc <> "," + , flow "some values changed in the new package metadata:" + , fromString . T.unpack $ textDisplay pm <> "." + ] + pretty (CRC32Mismatch loc fp Mismatch {..}) = + "[S-607]" + <> line + <> fillSep + [ flow "CRC32 mismatch in Zip file from" + , pretty loc + , flow "on internal file" + , style File (fromString fp) + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ]) + pretty (UnknownHackagePackage pir fuzzy) = + "[S-476]" + <> line + <> fillSep + [ flow "Could not find" + , style Error (fromString . T.unpack $ textDisplay pir) + , flow "on Hackage." + ] + <> prettyFuzzy fuzzy + pretty (CannotCompleteRepoNonSHA1 repo) = + "[S-112]" + <> line + <> fillSep + [ flow "Cannot complete repo information for a non SHA1 commit due to" + , "non-reproducibility:" + , fromString . T.unpack $ textDisplay repo <> "." + ] + pretty (MutablePackageLocationFromUrl t) = + "[S-321]" + <> line + <> fillSep + [ flow "Cannot refer to a mutable package location from a URL:" + , style Url (fromString $ T.unpack t) <> "." + ] + pretty (MismatchedCabalFileForHackage pir Mismatch{..}) = + "[S-377]" + <> line + <> fillSep + [ flow "When processing Cabal file for Hackage package" + , fromString . T.unpack $ textDisplay pir <> "," + , flow "mismatched package identifier." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString (packageIdentifierString mismatchExpected) <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString (packageIdentifierString mismatchActual) <> "." + ]) + pretty (PackageNameParseFail t) = + "[S-580]" + <> line + <> fillSep + [ flow "Invalid package name:" + , fromString $ T.unpack t <> "." + ] + pretty (PackageVersionParseFail t) = + "[S-479]" + <> line + <> fillSep + [ flow "Invalid version:" + , fromString $ T.unpack t <> "." + ] + pretty (InvalidCabalFilePath fp) = + "[S-824]" + <> line + <> fillSep + [ flow "File path contains a name which is not a valid package name:" + , pretty fp <> "." + ] + pretty (DuplicatePackageNames source pairs') = + "[S-674]" + <> line + <> fillSep + [ flow "Duplicate package names" + , parens (fromString . T.unpack $ textDisplay source) <> ":" + ] + <> line + <> foldMap + ( \(name, locs) -> + fromString (packageNameString name) <> ":" + <> line + <> bulletedList (map pretty locs) + <> line + ) + pairs' + pretty (MigrationFailure desc fp err) = + "[S-536]" + <> line + <> fillSep + [ flow "Encountered error while migrating database" + , fromString $ T.unpack desc + , flow "located at" + , pretty fp <> ":" + ] + <> blankLine + <> string (displayException err) + pretty (ParseSnapNameException t) = + "[S-994]" + <> line + <> fillSep + [ flow "Invalid snapshot name:" + , fromString $ T.unpack t <> "." + ] + pretty (HpackLibraryException file err) = + "[S-305]" + <> line + <> fillSep + [ flow "Failed to generate a Cabal file using the Hpack library on" + , "file:" + , pretty file <> "." + , flow "The error encountered was:" + ] + <> blankLine + <> string err + pretty (HpackExeException fp dir err) = + "[S-720]" + <> line + <> fillSep + [ flow "Failed to generate a Cabal file using the Hpack executable:" + , style File (fromString fp) + , flow "in directory:" + , pretty dir <> "." + , flow "The error encountered was:" + ] + <> blankLine + <> string (displayException err) + +blankLine :: StyleDoc +blankLine = line <> line + +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) <> + "." + +prettyFuzzy :: FuzzyResults -> StyleDoc +prettyFuzzy (FRNameNotFound names) = + case NE.nonEmpty names of + Nothing -> mempty + Just names' -> + line + <> fillSep + ( flow "Perhaps you meant one of" + : mkNarrativeList Nothing False + (NE.toList $ NE.map (fromString . packageNameString) names' :: [StyleDoc]) + ) +prettyFuzzy (FRVersionNotFound pirs) = + line + <> fillSep + ( flow "Possible candidates:" + : mkNarrativeList Nothing False + (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc]) + ) +prettyFuzzy (FRRevisionNotFound pirs) = + line + <> fillSep + ( flow "The specified revision was not found. Possible candidates:" + : mkNarrativeList Nothing False + (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc]) + ) + +orSeparated :: NonEmpty Utf8Builder -> Utf8Builder +orSeparated xs + | NE.length xs == 1 = NE.head xs + | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs + | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs + +commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder +commaSeparated = fold . NE.intersperse ", " + +cabalSpecLatestVersion :: Version +cabalSpecLatestVersion = mkVersion $ cabalSpecToVersionDigits cabalSpecLatest + +#if !MIN_VERSION_Cabal(3,4,0) +cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] +cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] +cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] +cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] +cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] +cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] +cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] +cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] +cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] +cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] +cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] +cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] +cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] +cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] +cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] +cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] +#endif + +data BuildFile + = BFCabal !SafeFilePath !TreeEntry + | BFHpack !TreeEntry + -- We don't need SafeFilePath for Hpack since it has to be package.yaml file + deriving (Show, Eq) + +data FileType = FTNormal | FTExecutable + deriving (Show, Eq, Enum, Bounded, Ord) + +instance PersistField FileType where + toPersistValue FTNormal = PersistInt64 1 + toPersistValue FTExecutable = PersistInt64 2 + + fromPersistValue v = do + i <- fromPersistValue v + case i :: Int64 of + 1 -> Right FTNormal + 2 -> Right FTExecutable + _ -> Left $ "Invalid FileType: " <> tshow i + +instance PersistFieldSql FileType where + sqlType _ = SqlInt32 + +data TreeEntry = TreeEntry + { teBlob :: !BlobKey + , teType :: !FileType + } + deriving (Show, Eq, Ord) + +newtype SafeFilePath = SafeFilePath Text + deriving (Show, Eq, Ord, Display) + +instance PersistField SafeFilePath where + toPersistValue = toPersistValue . unSafeFilePath + fromPersistValue v = do + t <- fromPersistValue v + maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t + +instance PersistFieldSql SafeFilePath where + sqlType _ = SqlString + +unSafeFilePath :: SafeFilePath -> Text +unSafeFilePath (SafeFilePath t) = t + +safeFilePathToPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File) +safeFilePathToPath dir (SafeFilePath path) = do + fpath <- parseRelFile (T.unpack path) + pure $ 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 $ (not . any (T.all (== '.'))) $ T.split (== '/') t + + Just $ SafeFilePath t + +-- | SafeFilePath for `package.yaml` file. +hpackSafeFilePath :: SafeFilePath +hpackSafeFilePath = + let fpath = mkSafeFilePath (T.pack Hpack.packageConfig) + in case fpath of + Nothing -> error $ + "hpackSafeFilePath: Not able to encode " <> Hpack.packageConfig + Just sfp -> sfp + +-- | The hash of the binary representation of a 'Tree'. +-- +-- @since 0.1.0.0 +newtype TreeKey = TreeKey BlobKey + deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display) + +-- | Represents the contents of a tree, which is a mapping from +-- relative file paths to 'TreeEntry's. +-- +-- @since 0.1.0.0 +newtype Tree + = TreeMap (Map SafeFilePath TreeEntry) + -- In the future, consider allowing more lax parsing + -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys + -- TreeTarball !PackageTarball + deriving (Show, Eq, Ord) + +renderTree :: Tree -> ByteString +renderTree = BL.toStrict . toLazyByteString . go + where + go :: Tree -> Builder + go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m + + goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = + netstring (unSafeFilePath sfp) <> + byteString (SHA256.toRaw sha) <> + netword size' <> + (case ft of + FTNormal -> "N" + FTExecutable -> "X") + +netstring :: Text -> Builder +netstring t = + let bs = encodeUtf8 t + in netword (fromIntegral (B.length bs)) <> byteString bs + +netword :: Word -> Builder +netword w = wordDec w <> ":" + +parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree) +parseTreeM (blobKey, blob) = + case parseTree blob of + Nothing -> throwM (InvalidTreeFromCasa blobKey blob) + Just tree -> pure (TreeKey blobKey, tree) + +parseTree :: ByteString -> Maybe Tree +parseTree bs1 = do + tree <- parseTree' bs1 + let bs2 = renderTree tree + guard $ bs1 == bs2 + Just tree + +parseTree' :: ByteString -> Maybe Tree +parseTree' bs0 = do + entriesBS <- B.stripPrefix "map:" bs0 + TreeMap <$> loop Map.empty entriesBS + where + loop !m bs1 + | B.null bs1 = pure m + | otherwise = do + (sfpBS, bs2) <- takeNetstring bs1 + sfp <- + case decodeUtf8' sfpBS of + Left _ -> Nothing + Right sfpT -> mkSafeFilePath sfpT + (sha, bs3) <- takeSha bs2 + (size', bs4) <- takeNetword bs3 + (typeW, bs5) <- B.uncons bs4 + ft <- + case typeW of + 78 -> Just FTNormal -- 'N' + 88 -> Just FTExecutable -- 'X' + _ -> Nothing + let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft + loop (Map.insert sfp entry m) bs5 + + takeNetstring bs1 = do + (size', bs2) <- takeNetword bs1 + guard $ B.length bs2 >= size' + Just $ B.splitAt size' bs2 + + takeSha bs = do + let (x, y) = B.splitAt 32 bs + x' <- either (const Nothing) Just (SHA256.fromRaw x) + Just (x', y) + + takeNetword = + go 0 + where + go !accum bs = do + (next, rest) <- B.uncons bs + if + | next == 58 -> pure (accum, rest) -- ':' + | next >= 48 && next <= 57 -> + go + (accum * 10 + fromIntegral (next - 48)) + rest + | otherwise -> Nothing + + {- +data PackageTarball = PackageTarball + { ptBlob :: !BlobKey + -- ^ Contains the tarball itself + , ptCabal :: !BlobKey + -- ^ Contains the cabal file contents + , ptSubdir :: !FilePath + -- ^ Subdir containing the files we want for this package. + -- + -- There must be precisely one file with a @.cabal@ file extension + -- located there. Thanks to Hackage revisions, its contents will be + -- overwritten by the value of @ptCabal@. + } + deriving Show + -} + +-- | This is almost a copy of Cabal's parser for package identifiers, +-- the main difference is in the fact that Stack requires version to be +-- present while Cabal uses "null version" as a default value +-- +-- @since 0.1.0.0 +parsePackageIdentifier :: String -> Maybe PackageIdentifier +parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof) + +packageIdentifierParsec :: ParsecParser PackageIdentifier +packageIdentifierParsec = do + ident@(PackageIdentifier _ v) <- parsec + + -- version is a required component of a package identifier for Stack + guard (v /= nullVersion) + + pure ident + +-- | Parse a package name from a 'String'. +-- +-- @since 0.1.0.0 +parsePackageName :: String -> Maybe PackageName +parsePackageName = Distribution.Text.simpleParse + +-- | Parse a package name from a 'String' throwing on failure +-- +-- @since 0.1.0.0 +parsePackageNameThrowing :: MonadThrow m => String -> m PackageName +parsePackageNameThrowing str = + case parsePackageName str of + Nothing -> throwM $ PackageNameParseFail $ T.pack str + Just pn -> pure pn + +-- | Parse a version from a 'String'. +-- +-- @since 0.1.0.0 +parseVersion :: String -> Maybe Version +parseVersion = Distribution.Text.simpleParse + +-- | Parse a package version from a 'String' throwing on failure +-- +-- @since 0.1.0.0 +parseVersionThrowing :: MonadThrow m => String -> m Version +parseVersionThrowing str = + case parseVersion str of + Nothing -> throwM $ PackageVersionParseFail $ T.pack str + Just v -> pure v + +-- | Parse a version range from a 'String'. +-- +-- @since 0.1.0.0 +parseVersionRange :: String -> Maybe VersionRange +parseVersionRange = Distribution.Text.simpleParse + +-- | Parse a module name from a 'String'. +-- +-- @since 0.1.0.0 +parseModuleName :: String -> Maybe ModuleName +parseModuleName = Distribution.Text.simpleParse + +-- | Parse a flag name from a 'String'. +-- +-- @since 0.1.0.0 +parseFlagName :: String -> Maybe FlagName +parseFlagName = Distribution.Text.simpleParse + +-- | Render a package name as a 'String'. +-- +-- @since 0.1.0.0 +packageNameString :: PackageName -> String +packageNameString = unPackageName + +-- | Render a package identifier as a 'String'. +-- +-- @since 0.1.0.0 +packageIdentifierString :: PackageIdentifier -> String +packageIdentifierString = Distribution.Text.display + +-- | Render a version as a 'String'. +-- +-- @since 0.1.0.0 +versionString :: Version -> String +versionString = Distribution.Text.display + +-- | Render a flag name as a 'String'. +-- +-- @since 0.1.0.0 +flagNameString :: FlagName -> String +flagNameString = unFlagName + +-- | Render a module name as a 'String'. +-- +-- @since 0.1.0.0 +moduleNameString :: ModuleName -> String +moduleNameString = Distribution.Text.display + +data OptionalSubdirs + = OSSubdirs !(NonEmpty Text) + | OSPackageMetadata !Text !RawPackageMetadata + -- ^ subdirectory and package metadata + deriving (Show, Eq, Generic) + +instance NFData OptionalSubdirs + +-- | Metadata provided by a config file for archives and repos. This information +-- can be used for optimized lookups of information like package identifiers, or +-- for validating that the user configuration has the expected information. +-- +-- @since 0.1.0.0 +data RawPackageMetadata = RawPackageMetadata + { rpmName :: !(Maybe PackageName) + -- ^ Package name in the cabal file + -- + -- @since 0.1.0.0 + , rpmVersion :: !(Maybe Version) + -- ^ Package version in the cabal file + -- + -- @since 0.1.0.0 + , rpmTreeKey :: !(Maybe TreeKey) + -- ^ Tree key of the loaded up package + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord, Generic, Typeable) + +instance NFData RawPackageMetadata + +instance Display RawPackageMetadata where + display rpm = fold $ intersperse ", " $ catMaybes + [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm + , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm + , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm + ] + +-- | Exact metadata specifying concrete package +-- +-- @since 0.1.0.0 +data PackageMetadata = PackageMetadata + { pmIdent :: !PackageIdentifier + -- ^ Package identifier in the cabal file + -- + -- @since 0.1.0.0 + , pmTreeKey :: !TreeKey + -- ^ Tree key of the loaded up package + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord, Generic, Typeable) + +-- i PackageMetadata +instance NFData PackageMetadata + +instance Display PackageMetadata where + display pm = fold $ intersperse ", " + [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm) + , "tree == " <> display (pmTreeKey pm) + ] + +parsePackageMetadata :: Object -> WarningParser PackageMetadata +parsePackageMetadata o = do + _oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file" + pantryTree :: BlobKey <- o ..: "pantry-tree" + CabalString pkgName <- o ..: "name" + CabalString pkgVersion <- o ..: "version" + let pmTreeKey = TreeKey pantryTree + pmIdent = PackageIdentifier {..} + pure PackageMetadata {..} + + +-- | Convert package metadata to its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawPM :: PackageMetadata -> RawPackageMetadata +toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) + where + PackageIdentifier name version = pmIdent pm + +-- | File path relative to the configuration file it was parsed from +-- +-- @since 0.1.0.0 +newtype RelFilePath = RelFilePath Text + deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display) + +-- | Location that an archive is stored at +-- +-- @since 0.1.0.0 +data ArchiveLocation + = ALUrl !Text + -- ^ Archive stored at an HTTP(S) URL + -- + -- @since 0.1.0.0 + | ALFilePath !(ResolvedPath File) + -- ^ Archive stored at a local file path + -- + -- @since 0.1.0.0 + deriving (Show, Eq, Ord, Generic, Typeable) + +instance NFData ArchiveLocation + +instance Display ArchiveLocation where + display (ALUrl url) = display url + display (ALFilePath resolved) = + fromString $ toFilePath $ resolvedAbsolute resolved + +instance Pretty ArchiveLocation where + pretty (ALUrl url) = style Url (fromString $ T.unpack url) + pretty (ALFilePath resolved) = pretty $ resolvedAbsolute resolved + +parseArchiveLocationObject :: + Object + -> WarningParser (Unresolved ArchiveLocation) +parseArchiveLocationObject o = + ((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl) + <|> ((o ..: "filepath") >>= either (fail . T.unpack) pure . validateFilePath) + <|> ((o ..: "archive") >>= either (fail . T.unpack) pure . parseArchiveLocationText) + <|> ((o ..: "location") >>= either (fail . T.unpack) pure . parseArchiveLocationText) + +parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation) +parseArchiveLocationText t = + case validateUrl t of + Left e1 -> + case validateFilePath t of + Left e2 -> Left $ T.unlines + [ "Invalid archive location, neither a URL nor a file path" + , " URL error: " <> e1 + , " File path error: " <> e2 + ] + Right x -> Right x + Right x -> Right x + +validateUrl :: Text -> Either Text (Unresolved ArchiveLocation) +validateUrl t = + case parseRequest $ T.unpack t of + Left _ -> Left $ "Could not parse URL: " <> t + Right _ -> pure $ pure $ ALUrl t + +validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation) +validateFilePath t = + if any (`T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") + then pure $ Unresolved $ \case + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir $ T.unpack t + pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' + else Left $ "Does not have an archive file extension: " <> t + +instance ToJSON RawPackageLocation where + toJSON (RPLImmutable rpli) = toJSON rpli + toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved) + +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where + parseJSON v = + (fmap . fmap . fmap . fmap) RPLImmutable (parseJSON v) <|> + (noJSONWarnings . mkMutable <$> parseJSON v) + where + mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation) + mkMutable t = Unresolved $ \mdir -> do + case mdir of + Nothing -> throwIO $ MutablePackageLocationFromUrl t + Just dir -> do + abs' <- resolveDir dir $ T.unpack t + pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs' + +instance ToJSON RawPackageLocationImmutable where + toJSON (RPLIHackage pir mtree) = object $ + ("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 + , [ "subdir" .= subdir | not (T.null subdir) ] + , rpmToPairs rpm + ] + toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat + [ [ urlKey .= url + , "commit" .= commit + ] + , ["subdir" .= subdir | not (T.null subdir) ] + , rpmToPairs rpm + ] + where + urlKey = + case typ of + RepoGit -> "git" + RepoHg -> "hg" + +rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)] +rpmToPairs (RawPackageMetadata mname mversion mtree) = concat + [ maybe [] (\name -> ["name" .= CabalString name]) mname + , maybe [] (\version -> ["version" .= CabalString version]) mversion + , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree + ] + +instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where + parseJSON v = + repoObject v + <|> archiveObject v + <|> hackageObject v + <|> github v + <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) + where + repoObject :: + Value + -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) + repoObject = + withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do + pm <- parsePackageMetadata o + repoSubdir <- o ..:? "subdir" ..!= "" + repoCommit <- o ..: "commit" + (repoType, repoUrl) <- + (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> + (o ..: "hg" >>= \url -> pure (RepoHg, url)) + pure $ pure $ PLIRepo Repo {..} pm + + archiveObject = + withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do + pm <- parsePackageMetadata o + Unresolved mkArchiveLocation <- parseArchiveLocationObject o + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..:? "subdir" ..!= "" + pure $ Unresolved $ \mdir -> do + archiveLocation <- mkArchiveLocation mdir + pure $ PLIArchive Archive {..} pm + + hackageObject = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do + treeKey <- o ..: "pantry-tree" + htxt <- o ..: "hackage" + case parseHackageText htxt of + Left e -> fail $ show e + Right (pkgIdentifier, blobKey) -> + pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) + + github = + 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) + +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where + parseJSON v = + http v + <|> hackageText v + <|> hackageObject v + <|> repo v + <|> archiveObject v + <|> github v + <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) + where + http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) + http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> + case parseArchiveLocationText t of + Left _ -> fail $ "Invalid archive location: " ++ T.unpack t + Right (Unresolved mkArchiveLocation) -> + pure $ noJSONWarnings $ Unresolved $ \mdir -> do + raLocation <- mkArchiveLocation mdir + let raHash = Nothing + raSize = Nothing + raSubdir = T.empty + pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty + + hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing + + hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> pure . pure <$> (RPLIHackage + <$> o ..: "hackage" + <*> o ..:? "pantry-tree") + + optionalSubdirs :: Object -> WarningParser OptionalSubdirs + optionalSubdirs o = + -- if subdirs exists, it needs to be valid + case HM.lookup "subdirs" o of + Just v' -> do + tellJSONField "subdirs" + subdirs <- lift $ parseJSON v' + case NE.nonEmpty subdirs of + Nothing -> fail "Invalid empty subdirs" + Just x -> pure $ OSSubdirs x + Nothing -> OSPackageMetadata + <$> o ..:? "subdir" ..!= T.empty + <*> ( rawPackageMetadataHelper + <$> (fmap unCabalString <$> (o ..:? "name")) + <*> (fmap unCabalString <$> (o ..:? "version")) + <*> o ..:? "pantry-tree" + <*> o ..:? "cabal-file" + ) + + rawPackageMetadataHelper :: + Maybe PackageName + -> Maybe Version + -> Maybe TreeKey + -> Maybe BlobKey + -> RawPackageMetadata + rawPackageMetadataHelper name version pantryTree _ignoredCabalFile = + RawPackageMetadata name version pantryTree + + repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do + (repoType, repoUrl) <- + ((RepoGit, ) <$> o ..: "git") <|> + ((RepoHg, ) <$> o ..: "hg") + repoCommit <- o ..: "commit" + os <- optionalSubdirs o + pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) + + archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do + Unresolved mkArchiveLocation <- parseArchiveLocationObject o + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + os <- optionalSubdirs o + pure $ Unresolved $ \mdir -> do + raLocation <- mkArchiveLocation mdir + pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) + + github = withObjectWarnings "PLArchive:github" $ \o -> do + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + let raLocation = ALUrl $ T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + os <- optionalSubdirs o + pure $ pure $ + NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) + +-- | Returns pairs of subdirectory and 'PackageMetadata'. +osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata) +osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs +osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm) + +rpmEmpty :: RawPackageMetadata +rpmEmpty = RawPackageMetadata Nothing Nothing Nothing + +-- | Newtype wrapper for easier JSON integration with Cabal types. +-- +-- @since 0.1.0.0 +newtype CabalString a = CabalString { unCabalString :: a } + deriving (Show, Eq, Ord, Typeable) + +-- I'd like to use coerce here, but can't due to roles. unsafeCoerce +-- could work, but let's avoid unsafe code. + +-- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON' +-- instance. +-- +-- @since 0.1.0.0 +toCabalStringMap :: Map a v -> Map (CabalString a) v +toCabalStringMap = Map.mapKeysMonotonic CabalString + +-- | Unwrap the 'CabalString' from the keys in a 'Map' to use a +-- 'FromJSON' instance. +-- +-- @since 0.1.0.0 +unCabalStringMap :: Map (CabalString a) v -> Map a v +unCabalStringMap = Map.mapKeysMonotonic unCabalString + +instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where + toJSON = toJSON . Distribution.Text.display . unCabalString + +instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where + toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString + +instance forall a. IsCabalString a => FromJSON (CabalString a) where + parseJSON = withText name $ \t -> + case cabalStringParser $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) + +instance forall a. IsCabalString a => FromJSONKey (CabalString a) where + fromJSONKey = + FromJSONKeyTextParser $ \t -> + case cabalStringParser $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) + +class IsCabalString a where + cabalStringName :: proxy a -> String + cabalStringParser :: String -> Maybe a + +instance IsCabalString PackageName where + cabalStringName _ = "package name" + cabalStringParser = parsePackageName + +instance IsCabalString Version where + cabalStringName _ = "version" + cabalStringParser = parseVersion + +instance IsCabalString VersionRange where + cabalStringName _ = "version range" + cabalStringParser = parseVersionRange + +instance IsCabalString PackageIdentifier where + cabalStringName _ = "package identifier" + cabalStringParser = parsePackageIdentifier + +instance IsCabalString FlagName where + cabalStringName _ = "flag name" + cabalStringParser = parseFlagName + +-- | What to use for running hpack +-- +-- @since 0.1.0.0 +data HpackExecutable + = HpackBundled + -- ^ Compiled in library + | HpackCommand !FilePath + -- ^ Executable at the provided path + deriving (Show, Read, Eq, Ord) + + +-- | Which compiler a snapshot wants to use. The build tool may elect to do some +-- fuzzy matching of versions (e.g., allowing different patch versions). +-- +-- @since 0.1.0.0 +data WantedCompiler + = WCGhc !Version + | WCGhcGit !Text !Text + | WCGhcjs + !Version + !Version + -- ^ GHCJS version followed by GHC version + deriving (Show, Eq, Ord, Generic) + +instance NFData WantedCompiler + +instance Display WantedCompiler where + display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) + display (WCGhcjs vghcjs vghc) = + "ghcjs-" + <> fromString (versionString vghcjs) + <> "_ghc-" <> fromString (versionString vghc) + display (WCGhcGit commit flavour) = + "ghc-git-" <> display commit <> "-" <> display flavour + +instance ToJSON WantedCompiler where + toJSON = toJSON . utf8BuilderToText . display + +instance FromJSON WantedCompiler where + parseJSON = + withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler + +instance FromJSONKey WantedCompiler where + fromJSONKey = + FromJSONKeyTextParser $ \t -> + case parseWantedCompiler t of + Left e -> fail $ "Invalid WantedCompiler " ++ show t ++ ": " ++ show e + Right x -> pure x + +-- | Parse a 'Text' into a 'WantedCompiler' value. +-- +-- @since 0.1.0.0 +parseWantedCompiler :: Text -> Either PantryException WantedCompiler +parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ + case T.stripPrefix "ghcjs-" t0 of + Just t1 -> parseGhcjs t1 + Nothing -> case T.stripPrefix "ghc-git-" t0 of + Just t1 -> parseGhcGit t1 + Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc + where + parseGhcjs t1 = do + let (ghcjsVT, t2) = T.break (== '_') t1 + ghcjsV <- parseVersion $ T.unpack ghcjsVT + ghcVT <- T.stripPrefix "_ghc-" t2 + ghcV <- parseVersion $ T.unpack ghcVT + pure $ WCGhcjs ghcjsV ghcV + parseGhcGit t1 = do + let (commit, flavour) = T.break (== '-') t1 + pure $ WCGhcGit commit (T.drop 1 flavour) + parseGhc = fmap WCGhc . parseVersion . T.unpack + +instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where + parseJSON v = text v <|> obj v + where + text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) + text = + withText "UnresolvedSnapshotLocation (Text)" $ + pure . noJSONWarnings . parseRawSnapshotLocation + + obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) + obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> + (pure . RSLCompiler <$> o ..: "compiler") <|> + ((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|> + (parseRawSnapshotLocationPath <$> o ..: "filepath") + + blobKey o = do + msha <- o ..:? "sha256" + msize <- o ..:? "size" + case (msha, msize) of + (Nothing, Nothing) -> pure Nothing + (Just sha, Just size') -> pure $ Just $ BlobKey sha size' + (Just _sha, Nothing) -> fail "You must also specify the file size" + (Nothing, Just _) -> fail "You must also specify the file's SHA256" + +instance Display SnapshotLocation where + display (SLCompiler compiler) = display compiler + display (SLUrl url blob) = display url <> " (" <> display blob <> ")" + display (SLFilePath resolved) = display (resolvedRelative resolved) + +-- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. +-- +-- @since 0.1.0.0 +parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation +parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $ + either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0) <|> + (pure . RSLSynonym <$> parseSnapName t0) <|> + parseGitHub <|> + parseUrl + where + parseGitHub = do + t1 <- T.stripPrefix "github:" t0 + let (user, t2) = T.break (== '/') t1 + t3 <- T.stripPrefix "/" t2 + let (repo, t4) = T.break (== ':') t3 + path <- T.stripPrefix ":" t4 + Just $ pure $ githubSnapshotLocation user repo path + + parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) + +parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation +parseRawSnapshotLocationPath t = + Unresolved $ \case + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) + pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' + +githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation +githubSnapshotLocation user repo path = + let url = T.concat + [ "https://raw.githubusercontent.com/" + , user + , "/" + , repo + , "/master/" + , path + ] + in RSLUrl url Nothing + +defUser :: Text +defUser = "commercialhaskell" + +defRepo :: Text +defRepo = "stackage-snapshots" + +-- | Default location of snapshot synonyms, i.e. commercialhaskell's GitHub +-- repository. +-- +-- @since 0.5.0.0 +defaultSnapshotLocation :: + SnapName + -> RawSnapshotLocation +defaultSnapshotLocation (LTS x y) = + githubSnapshotLocation defUser defRepo $ + utf8BuilderToText $ + "lts/" <> display x <> "/" <> display y <> ".yaml" +defaultSnapshotLocation (Nightly date) = + githubSnapshotLocation defUser defRepo + $ utf8BuilderToText + $ "nightly/" + <> display year + <> "/" + <> display month + <> "/" + <> display day + <> ".yaml" + where + (year, month, day) = toGregorian date + +-- | A snapshot synonym. It is expanded according to the field +-- 'snapshotLocation' of a 'PantryConfig'. +-- +-- @ since 0.5.0.0 +data SnapName + = LTS + !Int -- ^ Major version + !Int -- ^ Minor version + -- ^ LTS Haskell snapshot, displayed as @"lts-maj.min"@. + -- + -- @since 0.5.0.0 + | Nightly !Day + -- ^ Stackage Nightly snapshot, displayed as @"nighly-YYYY-MM-DD"@. + -- + -- @since 0.5.0.0 + deriving (Eq, Ord, Generic) + +instance NFData SnapName + +instance Display SnapName where + display (LTS x y) = "lts-" <> display x <> "." <> display y + display (Nightly date) = "nightly-" <> displayShow date + +instance Show SnapName where + show = T.unpack . utf8BuilderToText . display + +instance ToJSON SnapName where + toJSON syn = String $ utf8BuilderToText $ display syn + +-- | Parse the short representation of a 'SnapName'. +-- +-- @since 0.5.0.0 +parseSnapName :: MonadThrow m => Text -> m SnapName +parseSnapName t0 = + case lts <|> nightly of + Nothing -> throwM $ ParseSnapNameException t0 + Just sn -> pure sn + where + lts = do + t1 <- T.stripPrefix "lts-" t0 + Right (x, t2) <- Just $ decimal t1 + t3 <- T.stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + pure $ LTS x y + nightly = do + t1 <- T.stripPrefix "nightly-" t0 + Nightly <$> readMaybe (T.unpack t1) + +-- | Where to load a snapshot from in raw form (RSUrl could have a missing +-- BlobKey) +-- +-- @since 0.1.0.0 +data RawSnapshotLocation + = RSLCompiler !WantedCompiler + -- ^ Don't use an actual snapshot, just a version of the compiler with its + -- shipped packages. + -- + -- @since 0.1.0.0 + | RSLUrl !Text !(Maybe BlobKey) + -- ^ Download the snapshot from the given URL. The optional 'BlobKey' is + -- used for reproducibility. + -- + -- @since 0.1.0.0 + | RSLFilePath !(ResolvedPath File) + -- ^ Snapshot at a local file path. + -- + -- @since 0.1.0.0 + | RSLSynonym !SnapName + -- ^ Snapshot synonym (LTS/Nightly). + -- + -- @since 0.5.0.0 + deriving (Show, Eq, Ord, Generic) + +instance NFData RawSnapshotLocation + +instance Display RawSnapshotLocation where + display (RSLCompiler compiler) = display compiler + display (RSLUrl url Nothing) = display url + display (RSLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" + display (RSLFilePath resolved) = display (resolvedRelative resolved) + display (RSLSynonym syn) = display syn + +instance Pretty RawSnapshotLocation where + pretty (RSLCompiler compiler) = fromString . T.unpack $ textDisplay compiler + pretty (RSLUrl url Nothing) = style Url (fromString $ T.unpack url) + pretty (RSLUrl url (Just blob)) = fillSep + [ style Url (fromString $ T.unpack url) + , parens (fromString . T.unpack $ textDisplay blob) + ] + pretty (RSLFilePath resolved) = + style File (fromString . T.unpack $ textDisplay (resolvedRelative resolved)) + pretty (RSLSynonym syn) = + style Shell (fromString . T.unpack $ textDisplay syn) + +instance ToJSON RawSnapshotLocation where + toJSON (RSLCompiler compiler) = object ["compiler" .= compiler] + toJSON (RSLUrl url mblob) = object + $ "url" .= url + : maybe [] blobKeyPairs mblob + toJSON (RSLFilePath resolved) = + object ["filepath" .= resolvedRelative resolved] + toJSON (RSLSynonym syn) = toJSON syn + +-- | Where to load a snapshot from. +-- +-- @since 0.1.0.0 +data SnapshotLocation + = SLCompiler !WantedCompiler + -- ^ Don't use an actual snapshot, just a version of the compiler + -- with its shipped packages. + -- + -- @since 0.1.0.0 + | SLUrl !Text !BlobKey + -- ^ Download the snapshot from the given URL. The optional + -- 'BlobKey' is used for reproducibility. + -- + -- @since 0.1.0.0 + | SLFilePath !(ResolvedPath File) + -- ^ Snapshot at a local file path. + -- + -- @since 0.1.0.0 + deriving (Show, Eq, Ord, Generic) + +instance NFData SnapshotLocation + +instance ToJSON SnapshotLocation where + toJSON sl = toJSON (toRawSL sl) + +instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where + parseJSON v = file v <|> url v <|> compiler v + where + file = withObjectWarnings "SLFilepath" $ \o -> do + ufp <- o ..: "filepath" + pure $ Unresolved $ \case + 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] + , [ "drop-packages" .= Set.map CabalString (rslDropPackages rsnap) + | not (Set.null (rslDropPackages rsnap)) + ] + , [ "flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap)) + | not(Map.null (rslFlags rsnap)) + ] + , [ "hidden" .= toCabalStringMap (rslHidden rsnap) + | not (Map.null (rslHidden rsnap)) + ] + , [ "ghc-options" .= toCabalStringMap (rslGhcOptions rsnap) + | not (Map.null (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 {..}) + <$> (concatMap 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] + , [ "drop-packages" .= Set.map CabalString (slDropPackages snap) + | not (Set.null (slDropPackages snap)) + ] + , [ "flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap)) + | not (Map.null (slFlags snap)) + ] + , [ "hidden" .= toCabalStringMap (slHidden snap) + | not (Map.null (slHidden snap)) + ] + , [ "ghc-options" .= toCabalStringMap (slGhcOptions snap) + | not (Map.null (slGhcOptions snap)) + ] + , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap) + ] + +-- | Convert snapshot layer into its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer +toRawSnapshotLayer sl = RawSnapshotLayer + { rslParent = toRawSL (slParent sl) + , rslCompiler = slCompiler sl + , rslLocations = map toRawPLI (slLocations sl) + , rslDropPackages = slDropPackages sl + , rslFlags = slFlags sl + , rslHidden = slHidden sl + , rslGhcOptions = slGhcOptions sl + , rslPublishTime = slPublishTime sl + } + +-- | An arbitrary hash for a snapshot, used for finding module names in a +-- snapshot. Mostly intended for Stack's usage. +-- +-- @since 0.1.0.0 +newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} + deriving (Show) + +-- | Get the path to the global hints cache file +getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File) +getGlobalHintsFile = do + root <- view $ pantryConfigL.to pcRootDir + globalHintsRelFile <- parseRelFile "global-hints-cache.yaml" + pure $ root globalHintsRelFile + +-- | Creates BlobKey for an input ByteString +-- +-- @since 0.1.0.0 +bsToBlobKey :: ByteString -> BlobKey +bsToBlobKey bs = + BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) + +-- | Warn if the package uses 'PCHpack'. +-- +-- @since 0.4.0.0 +warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env () +warnMissingCabalFile loc = + logWarn $ + "DEPRECATED: The package at " + <> display loc + <> " does not include a cabal file.\n" + <> "Instead, it includes an hpack package.yaml file for generating a cabal file.\n" + <> "This usage is deprecated; please see " + <> "https://github.com/commercialhaskell/stack/issues/5210.\n" + <> "Support for this workflow will be removed in the future.\n" diff --git a/pantry.cabal b/pantry.cabal --- a/pantry.cabal +++ b/pantry.cabal @@ -1,275 +1,354 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.35.2. --- --- see: https://github.com/sol/hpack - -name: pantry -version: 0.8.3 -synopsis: Content addressable Haskell package management -description: Please see the README on GitHub at -category: Development -homepage: https://github.com/commercialhaskell/pantry#readme -bug-reports: https://github.com/commercialhaskell/pantry/issues -author: Michael Snoyman -maintainer: michael@snoyman.com -copyright: 2018-2022 FP Complete -license: BSD3 -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - ChangeLog.md - attic/hpack-0.1.2.3.tar.gz - attic/package-0.1.2.3.tar.gz - attic/symlink-to-dir.tar.gz - -source-repository head - type: git - location: https://github.com/commercialhaskell/pantry - -flag test-pretty-exceptions - description: Build an executable to test pretty exceptions - manual: False - default: False - -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.Casa - Pantry.Tree - Pantry.Types - hs-source-dirs: - src/ - ghc-options: -Wall - build-depends: - Cabal >=3 && <3.11 - , aeson - , ansi-terminal - , base >=4.10 && <5 - , bytestring - , casa-client - , casa-types - , conduit - , conduit-extra - , containers - , cryptonite - , cryptonite-conduit - , digest - , filelock - , generic-deriving - , hackage-security - , hpack >=0.35.1 - , http-client - , http-client-tls - , http-conduit - , http-download - , http-types - , memory - , mtl - , network-uri - , path - , path-io - , persistent - , persistent-sqlite >=2.9.3 - , persistent-template - , primitive - , resourcet - , rio - , rio-orphans - , rio-prettyprint - , tar-conduit - , text - , text-metrics - , time - , transformers - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - default-language: Haskell2010 - if impl(ghc >= 9.4.5) && os(windows) - build-depends: - network >=3.1.2.9 - if os(windows) - other-modules: - System.IsWindows - hs-source-dirs: - src/windows/ - else - other-modules: - System.IsWindows - hs-source-dirs: - src/unix/ - -executable test-pretty-exceptions - main-is: Main.hs - other-modules: - Paths_pantry - hs-source-dirs: - app/test-pretty-exceptions - ghc-options: -Wall - build-depends: - Cabal >=3 && <3.11 - , aeson - , ansi-terminal - , base >=4.10 && <5 - , bytestring - , casa-client - , casa-types - , conduit - , conduit-extra - , containers - , cryptonite - , cryptonite-conduit - , digest - , filelock - , generic-deriving - , hackage-security - , hpack >=0.35.1 - , http-client - , http-client-tls - , http-conduit - , http-download - , http-types - , memory - , mtl - , network-uri - , optparse-applicative - , pantry - , path - , path-io - , persistent - , persistent-sqlite >=2.9.3 - , persistent-template - , primitive - , resourcet - , rio - , rio-orphans - , rio-prettyprint - , tar-conduit - , text - , text-metrics - , time - , transformers - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - default-language: Haskell2010 - if impl(ghc >= 9.4.5) && os(windows) - build-depends: - network >=3.1.2.9 - if !flag(test-pretty-exceptions) - buildable: False - if os(windows) - other-modules: - PathAbsExamples - System.Terminal - hs-source-dirs: - app/test-pretty-exceptions/windows/ - build-depends: - Win32 - , process - else - other-modules: - PathAbsExamples - System.Terminal - hs-source-dirs: - app/test-pretty-exceptions/unix/ - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Pantry.ArchiveSpec - Pantry.BuildPlanSpec - Pantry.CabalSpec - Pantry.CasaSpec - Pantry.FileSpec - Pantry.GlobalHintsSpec - Pantry.HackageSpec - Pantry.Internal.StaticBytesSpec - Pantry.InternalSpec - Pantry.TreeSpec - Pantry.TypesSpec - Paths_pantry - hs-source-dirs: - test - ghc-options: -Wall - build-depends: - Cabal >=3 && <3.11 - , QuickCheck - , aeson - , ansi-terminal - , base >=4.10 && <5 - , bytestring - , casa-client - , casa-types - , conduit - , conduit-extra - , containers - , cryptonite - , cryptonite-conduit - , digest - , exceptions - , filelock - , generic-deriving - , hackage-security - , hedgehog - , hpack >=0.35.1 - , hspec - , http-client - , http-client-tls - , http-conduit - , http-download - , http-types - , memory - , mtl - , network-uri - , pantry - , path - , path-io - , persistent - , persistent-sqlite >=2.9.3 - , persistent-template - , primitive - , raw-strings-qq - , resourcet - , rio - , rio-orphans - , rio-prettyprint - , tar-conduit - , text - , text-metrics - , time - , transformers - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - default-language: Haskell2010 - if impl(ghc >= 9.4.5) && os(windows) - build-depends: - network >=3.1.2.9 +cabal-version: 2.0 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: pantry +version: 0.9.0 +synopsis: Content addressable Haskell package management +description: Please see the README on GitHub at +category: Development +homepage: https://github.com/commercialhaskell/pantry#readme +bug-reports: https://github.com/commercialhaskell/pantry/issues +author: Michael Snoyman +maintainer: michael@snoyman.com +copyright: 2018-2022 FP Complete +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + attic/hpack-0.1.2.3.tar.gz + attic/package-0.1.2.3.tar.gz + attic/symlink-to-dir.tar.gz + +source-repository head + type: git + location: https://github.com/commercialhaskell/pantry + +flag test-pretty-exceptions + description: Build an executable to test pretty exceptions + manual: False + default: False + +library + exposed-modules: + Pantry + Pantry.Internal.Stackage + other-modules: + Hackage.Security.Client.Repository.HttpLib.HttpClient + Pantry.Archive + Pantry.HTTP + Pantry.Hackage + Pantry.Repo + Pantry.Storage + Pantry.Casa + Pantry.Tree + reexported-modules: + Pantry.SHA256 + hs-source-dirs: + src/ + ghc-options: -Wall + build-depends: + Cabal >=3 && <3.11 + , aeson + , aeson-warning-parser + , ansi-terminal + , base >=4.10 && <5 + , bytestring + , casa-client + , casa-types + , companion + , conduit + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , digest + , filelock + , generic-deriving + , hackage-security + , hpack >=0.35.1 + , http-client + , http-client-tls + , http-conduit + , http-download + , http-types + , internal + , memory + , mtl + , network-uri + , path + , path-io + , persistent + , persistent-sqlite >=2.9.3 + , persistent-template + , primitive + , resourcet + , rio + , rio-orphans + , rio-prettyprint + , static-bytes + , tar-conduit + , text + , text-metrics + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 + if impl(ghc >= 9.4.5) && os(windows) + build-depends: + network >=3.1.2.9 + if os(windows) + other-modules: + System.IsWindows + hs-source-dirs: + src/windows/ + else + other-modules: + System.IsWindows + hs-source-dirs: + src/unix/ + +library internal + exposed-modules: + Pantry.HPack + Pantry.Internal + Pantry.SHA256 + Pantry.SQLite + Pantry.Types + other-modules: + Paths_pantry + autogen-modules: + Paths_pantry + hs-source-dirs: + int/ + ghc-options: -Wall + build-depends: + Cabal >=3 && <3.11 + , aeson + , aeson-warning-parser + , ansi-terminal + , base >=4.10 && <5 + , bytestring + , casa-client + , casa-types + , companion + , conduit + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , digest + , filelock + , generic-deriving + , hackage-security + , hpack >=0.35.1 + , http-client + , http-client-tls + , http-conduit + , http-download + , http-types + , memory + , mtl + , network-uri + , path + , path-io + , persistent + , persistent-sqlite >=2.9.3 + , persistent-template + , primitive + , resourcet + , rio + , rio-orphans + , rio-prettyprint + , static-bytes + , tar-conduit + , text + , text-metrics + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 + if impl(ghc >= 9.4.5) && os(windows) + build-depends: + network >=3.1.2.9 + +executable test-pretty-exceptions + main-is: Main.hs + other-modules: + Paths_pantry + autogen-modules: + Paths_pantry + hs-source-dirs: + app/test-pretty-exceptions + ghc-options: -Wall + build-depends: + Cabal >=3 && <3.11 + , aeson + , aeson-warning-parser + , ansi-terminal + , base >=4.10 && <5 + , bytestring + , casa-client + , casa-types + , companion + , conduit + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , digest + , filelock + , generic-deriving + , hackage-security + , hpack >=0.35.1 + , http-client + , http-client-tls + , http-conduit + , http-download + , http-types + , memory + , mtl + , network-uri + , optparse-applicative + , pantry + , path + , path-io + , persistent + , persistent-sqlite >=2.9.3 + , persistent-template + , primitive + , resourcet + , rio + , rio-orphans + , rio-prettyprint + , static-bytes + , tar-conduit + , text + , text-metrics + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 + if impl(ghc >= 9.4.5) && os(windows) + build-depends: + network >=3.1.2.9 + if !flag(test-pretty-exceptions) + buildable: False + if os(windows) + other-modules: + PathAbsExamples + System.Terminal + hs-source-dirs: + app/test-pretty-exceptions/windows/ + build-depends: + Win32 + , process + else + other-modules: + PathAbsExamples + System.Terminal + hs-source-dirs: + app/test-pretty-exceptions/unix/ + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Pantry.ArchiveSpec + Pantry.BuildPlanSpec + Pantry.CabalSpec + Pantry.CasaSpec + Pantry.FileSpec + Pantry.GlobalHintsSpec + Pantry.HackageSpec + Pantry.InternalSpec + Pantry.TreeSpec + Pantry.TypesSpec + Paths_pantry + autogen-modules: + Paths_pantry + hs-source-dirs: + test + ghc-options: -Wall + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + Cabal >=3 && <3.11 + , QuickCheck + , aeson + , aeson-warning-parser + , ansi-terminal + , base >=4.10 && <5 + , bytestring + , casa-client + , casa-types + , companion + , conduit + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , digest + , exceptions + , filelock + , generic-deriving + , hackage-security + , hedgehog + , hpack >=0.35.1 + , hspec + , http-client + , http-client-tls + , http-conduit + , http-download + , http-types + , internal + , memory + , mtl + , network-uri + , pantry + , path + , path-io + , persistent + , persistent-sqlite >=2.9.3 + , persistent-template + , primitive + , raw-strings-qq + , resourcet + , rio + , rio-orphans + , rio-prettyprint + , static-bytes + , tar-conduit + , text + , text-metrics + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 + if impl(ghc >= 9.4.5) && os(windows) + build-depends: + network >=3.1.2.9 diff --git a/src/Pantry.hs b/src/Pantry.hs --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -199,7 +199,8 @@ import Conduit import Control.Arrow ( right ) import Control.Monad.State.Strict ( State, execState, get, modify' ) -import Data.Aeson.Types ( parseEither ) +import Data.Aeson.Types ( Value, parseEither ) +import Data.Aeson.WarningParser ( WithJSONWarnings (..) ) #if !MIN_VERSION_rio(0,1,17) import Data.Bifunctor ( bimap ) #endif @@ -222,7 +223,6 @@ import Pantry.Casa import Pantry.HTTP import Pantry.Hackage -import Pantry.Internal.AesonExtended ( Value, WithJSONWarnings (..) ) import Pantry.Repo import qualified Pantry.SHA256 as SHA256 import Pantry.Storage hiding diff --git a/src/Pantry/HPack.hs b/src/Pantry/HPack.hs deleted file mode 100644 --- a/src/Pantry/HPack.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Pantry.HPack - ( hpack - , hpackVersion - ) where - -import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Char ( isDigit, isSpace ) -import qualified Hpack -import qualified Hpack.Config as Hpack -import Pantry.Types -import Path - ( Abs, Dir, Path, (), filename, parseRelFile, toFilePath ) -import Path.IO ( doesFileExist ) -import RIO -import RIO.Process - -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. Ignoring " - <> fromString (toFilePath hpackFile) - <> " in favor of the Cabal file.\n" - <> "Either please upgrade and try again or, if you want to use the " - <> fromString (toFilePath (filename hpackFile)) - <> " file instead of the Cabal file,\n" - <> "then please delete the Cabal file." - Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ - cabalFile - <> " was modified manually. Ignoring " - <> fromString (toFilePath hpackFile) - <> " in favor of the Cabal file.\n" - <> "If 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/Internal.hs b/src/Pantry/Internal.hs deleted file mode 100644 --- a/src/Pantry/Internal.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Exposed for testing, do not use! -module Pantry.Internal - ( parseTree - , renderTree - , Tree (..) - , TreeEntry (..) - , FileType(..) - , mkSafeFilePath - , pcHpackExecutable - , normalizeParents - , makeTarRelative - , getGlobalHintsFile - , hpackVersion - , Storage - , initStorage - , withStorage_ - ) where - -import Control.Exception ( assert ) -import Data.Maybe ( fromMaybe ) -import qualified Data.Text as T -import Pantry.HPack ( hpackVersion ) -import Pantry.SQLite ( initStorage ) -import Pantry.Types - --- | Like @System.FilePath.normalise@, however: --- --- * Only works on relative paths, absolute paths fail --- --- * Strips trailing slashes --- --- * Only works on forward slashes, even on Windows --- --- * Normalizes parent dirs @foo/../@ get stripped --- --- * Cannot begin with a parent directory (@../@) --- --- * Spelled like an American, sorry -normalizeParents :: - FilePath - -> Either String FilePath -normalizeParents "" = Left "empty file path" -normalizeParents ('/':_) = Left "absolute path" -normalizeParents ('.':'.':'/':_) = Left "absolute path" -normalizeParents fp = do - -- Strip a single trailing, but not multiple - let t0 = T.pack fp - t = fromMaybe t0 $ T.stripSuffix "/" t0 - case T.unsnoc t of - Just (_, '/') -> Left "multiple trailing slashes" - _ -> Right () - - let c1 = T.split (== '/') t - - case reverse c1 of - ".":_ -> Left "last component is a single dot" - _ -> Right () - - let c2 = filter (\x -> not (T.null x || x == ".")) c1 - - let loop [] routput = reverse routput - loop ("..":rest) (_:routput) = loop rest routput - loop (x:xs) routput = loop xs (x:routput) - - case loop c2 [] of - [] -> Left "no non-empty components" - c' -> Right $ T.unpack $ T.intercalate "/" c' - --- | Following tar file rules (Unix file paths only), make the second file --- relative to the first file. -makeTarRelative :: - FilePath -- ^ base file - -> FilePath -- ^ relative part - -> Either String FilePath -makeTarRelative _ ('/':_) = Left "absolute path found" -makeTarRelative base rel = - case reverse base of - [] -> Left "cannot have empty base" - '/':_ -> Left "base cannot be a directory" - _:rest -> Right $ - case dropWhile (/= '/') rest of - '/':rest' -> reverse rest' ++ '/' : rel - rest' -> assert (null rest') rel diff --git a/src/Pantry/Internal/AesonExtended.hs b/src/Pantry/Internal/AesonExtended.hs deleted file mode 100644 --- a/src/Pantry/Internal/AesonExtended.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - --- | Extensions to Aeson parsing of objects. This module is intended for --- internal use by Pantry and Stack only. The intention is to fully remove this --- module in the future. /DO NOT RELY ON IT/. -module Pantry.Internal.AesonExtended - ( module Export - -- * Extended failure messages - , (.:) - , (.:?) - -- * JSON Parser that emits warnings - , JSONWarning (..) - , WarningParser - , WithJSONWarnings (..) - , withObjectWarnings - , jsonSubWarnings - , jsonSubWarningsT - , jsonSubWarningsTT - , logJSONWarnings - , noJSONWarnings - , tellJSONField - , unWarningParser - , (..:) - , (...:) - , (..:?) - , (...:?) - , (..!=) - ) where - -import Control.Monad.Trans.Writer.Strict - ( WriterT, mapWriterT, runWriterT, tell ) -import Data.Aeson as Export hiding ( (.:), (.:?) ) -import qualified Data.Aeson as A -import Data.Aeson.Types hiding ( (.:), (.:?) ) -import qualified Data.Set as Set -import Data.Text ( unpack ) -import qualified Data.Text as T -import Generics.Deriving.Monoid ( mappenddefault, memptydefault ) -import RIO -import RIO.PrettyPrint.StylesUpdate ( StylesUpdate ) - -#if MIN_VERSION_aeson(2, 0, 0) -import qualified Data.Aeson.Key -import qualified Data.Aeson.KeyMap as HashMap - -keyToText :: Data.Aeson.Key.Key -> Text -keyToText = Data.Aeson.Key.toText - -textToKey :: Text -> Data.Aeson.Key.Key -textToKey = Data.Aeson.Key.fromText -#else -import qualified Data.HashMap.Strict as HashMap - -keyToText :: Text -> Text -keyToText = id - -textToKey :: Text -> Text -textToKey = id -#endif - --- | Extends @.:@ warning to include field name. -(.:) :: FromJSON a => Object -> Text -> Parser a -(.:) o p = modifyFailure - (("failed to parse field '" <> unpack p <> "': ") <>) - (o A..: textToKey p) -{-# INLINE (.:) #-} - --- | Extends @.:?@ warning to include field name. -(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a) -(.:?) o p = modifyFailure - (("failed to parse field '" <> unpack p <> "': ") <>) - (o A..:? textToKey p) -{-# INLINE (.:?) #-} - --- | 'WarningParser' version of @.:@. -(..:) :: - FromJSON a - => Object - -> Text - -> WarningParser a -o ..: k = tellJSONField k >> lift (o .: k) - --- | 'WarningParser' version of @.:?@. -(..:?) :: - FromJSON a - => Object - -> Text - -> WarningParser (Maybe a) -o ..:? k = tellJSONField k >> lift (o .:? k) - --- | 'WarningParser' version of @.!=@. -(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a -wp ..!= d = - flip mapWriterT wp $ - \p -> do - a <- fmap snd p - fmap (, a) (fmap fst p .!= d) - -presentCount :: Object -> [Text] -> Int -presentCount o = length . filter (\x -> HashMap.member (textToKey x) o) - --- | 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 = pure Nothing - | pc > 1 = fail $ - "failed to parse field " ++ - show key ++ ": " ++ - "two or more synonym keys " ++ - show ss ++ " present" - | otherwise = asum $ map (o..:) ss - --- | Tell warning parser about an expected field, so it doesn't warn about it. -tellJSONField :: Text -> WarningParser () -tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key}) - --- | 'WarningParser' version of 'withObject'. -withObjectWarnings :: - String - -> (Object -> WarningParser a) - -> Value - -> Parser (WithJSONWarnings a) -withObjectWarnings expected f = - withObject expected $ - \obj -> do - (a,w) <- runWriterT (f obj) - let unrecognizedFields = - Set.toList - ( Set.difference - (Set.fromList (map keyToText (HashMap.keys obj))) - (wpmExpectedFields w) - ) - pure - ( 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 - pure 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 - } - ) - pure result - --- | Handle warnings in a @Traversable@ of sub-objects. -jsonSubWarningsT :: - Traversable t - => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a) -jsonSubWarningsT f = - mapM (jsonSubWarnings . pure) =<< 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 . pure) =<< 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 deleted file mode 100644 --- a/src/Pantry/Internal/Companion.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RankNTypes #-} - --- | 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/StaticBytes.hs b/src/Pantry/Internal/StaticBytes.hs deleted file mode 100644 --- a/src/Pantry/Internal/StaticBytes.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - --- | 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 Data.Bits -import Data.ByteArray -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as B -import qualified Data.Primitive.ByteArray as BA -import qualified Data.Vector.Primitive as VP -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Unboxed.Base as VU -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable -import RIO hiding ( words ) -import System.IO.Unsafe ( unsafePerformIO ) - -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 _ [] = pure () - loop off (w:ws) = do - pokeElemOff (castPtr ptr) off w - loop (off + 1) ws - loop 0 words0 - pure $ 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 = pure 0 - | off' + 8 > len = do - let loop w64 i - | off' + i >= len = pure 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 (`B.fromForeignPtr` 0) - 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 = pure 0 - | off' + 8 > len = do - let loop w64 i - | off' + i >= len = pure 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 = pure $ 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/SHA256.hs b/src/Pantry/SHA256.hs deleted file mode 100644 --- a/src/Pantry/SHA256.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Provides a data type ('SHA256') for efficient memory representation of a --- sha-256 hash value, together with helper functions for converting to and from --- that value. This module is intended to be imported qualified as @SHA256@. --- --- Some nomenclature: --- --- * Hashing calculates a new hash value from some input. @from@ takes a value --- that represents an existing hash. --- --- * Raw means a raw binary representation of the hash value, without any hex --- encoding. --- --- * Text always uses lower case hex encoding --- --- @since 0.1.0.0 -module Pantry.SHA256 - ( -- * Types - SHA256 - , SHA256Exception (..) - -- * Hashing - , hashFile - , hashBytes - , hashLazyBytes - , sinkHash - -- * Convert from a hash representation - , fromHexText - , fromHexBytes - , fromDigest - , fromRaw - -- * Convert to a hash representation - , toHexText - , toHexBytes - , toRaw - ) where - -import Conduit -import qualified Crypto.Hash as Hash ( Digest, SHA256, hash, hashlazy ) -import qualified Crypto.Hash.Conduit as Hash ( hashFile, sinkHash ) -import Data.Aeson -import qualified Data.ByteArray -import qualified Data.ByteArray.Encoding as Mem -import Database.Persist.Sql -import Pantry.Internal.StaticBytes -import RIO -import qualified RIO.Text as T - --- | 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 - --- To support the Haskell Foundation's --- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry --- error messages generated by Pantry itself begin with an unique code in the --- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999. --- The numbers are selected at random, not in sequence. -instance Display SHA256Exception where - display (InvalidByteCount bs sbe) = - "Error: [S-161]\n" - <> "Invalid byte count creating a SHA256 from " - <> displayShow bs - <> ": " - <> displayShow sbe - display (InvalidHexBytes bs t) = - "Error: [S-165]\n" - <> "Invalid hex bytes creating a SHA256: " - <> displayShow bs - <> ": " - <> display t diff --git a/src/Pantry/SQLite.hs b/src/Pantry/SQLite.hs deleted file mode 100644 --- a/src/Pantry/SQLite.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Pantry.SQLite - ( Storage (..) - , initStorage - ) where - -import Database.Persist.Sqlite -import Pantry.Internal.Companion -import Pantry.Types - ( PantryException (MigrationFailure), Storage (..) ) -import Path ( Abs, File, Path, parent, toFilePath ) -import Path.IO ( ensureDir ) -import RIO hiding ( FilePath ) -import RIO.Orphans () -import System.FileLock - ( SharedExclusive (..), withFileLock, withTryFileLock ) - -initStorage :: - HasLogFunc env - => Text - -> Migration - -> Path Abs File -- ^ storage file - -> (Storage -> RIO env a) - -> RIO env a -initStorage description migration fp inner = do - ensureDir $ parent fp - - migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $ - withSqliteConnInfo (sqinfo True) $ runSqlConn $ - runMigrationSilent migration - forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig - - -- Make a single connection to the SQLite database and wrap it in an MVar for - -- the entire execution context. Previously we used a resource pool of size - -- 1, but (1) there's no advantage to that, and (2) it had a _very_ weird - -- interaction with Docker on OS X where when resource-pool's reaper would - -- trigger, it would somehow cause the Stack process inside the container to - -- die with a SIGBUS. Definitely an interesting thing worth following up - -- on... - withSqliteConnInfo (sqinfo False) $ \conn0 -> do - connVar <- newMVar conn0 - inner $ Storage - -- NOTE: Currently, we take a write lock on every action. This is - -- a bit heavyweight, but it avoids the SQLITE_BUSY errors - -- reported in - -- - -- completely. We can investigate more elegant solutions in the - -- future, such as separate read and write actions or introducing - -- smarter retry logic. - { withStorage_ = \action -> withMVar connVar $ \conn -> - withWriteLock (display description) fp $ - runSqlConn action conn - , withWriteLock_ = id - } - where - wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp) - - sqinfo isMigration - = set extraPragmas ["PRAGMA busy_timeout=2000;"] - $ set walEnabled False - - -- When doing a migration, we want to disable foreign key checking, since - -- the order in which tables are created by the migration scripts may not - -- respect foreign keys. The rest of the time: enforce those foreign keys. - $ set fkEnabled (not isMigration) - - $ mkSqliteConnectionInfo (fromString $ toFilePath fp) - --- | Ensure that only one process is trying to write to the database at a time. --- See https://github.com/commercialhaskell/stack/issues/4471 and comments --- above. -withWriteLock :: - HasLogFunc env - => Utf8Builder -- ^ database description, for lock messages - -> Path Abs File -- ^ SQLite database file - -> RIO env a - -> RIO env a -withWriteLock desc dbFile inner = do - let lockFile = toFilePath dbFile ++ ".pantry-write-lock" - withRunInIO $ \run -> do - mres <- withTryFileLock lockFile Exclusive $ const $ run inner - case mres of - Just res -> pure res - Nothing -> do - let complainer :: Companion IO - complainer delay = run $ do - -- Wait five seconds before giving the first message to - -- avoid spamming the user for uninteresting file locks - delay $ 5 * 1000 * 1000 -- 5 seconds - logInfo $ - "Unable to get a write lock on the " - <> desc - <> " database, waiting..." - - -- Now loop printing a message every 1 minute - forever $ do - delay (60 * 1000 * 1000) -- 1 minute - `onCompanionDone` logInfo - ( "Acquired the " - <> desc - <> " database write lock" - ) - logWarn - ( "Still waiting on the " - <> desc - <> " database write lock..." - ) - withCompanion complainer $ \stopComplaining -> - withFileLock lockFile Exclusive $ const $ do - stopComplaining - run inner diff --git a/src/Pantry/Types.hs b/src/Pantry/Types.hs deleted file mode 100644 --- a/src/Pantry/Types.hs +++ /dev/null @@ -1,3320 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - -module Pantry.Types - ( PantryConfig (..) - , PackageIndexConfig (..) - , HackageSecurityConfig (..) - , defaultHackageSecurityConfig - , Storage (..) - , HasPantryConfig (..) - , BlobKey (..) - , PackageName - , Version - , PackageIdentifier (..) - , Revision (..) - , ModuleName - , CabalFileInfo (..) - , PrintWarnings (..) - , PackageNameP (..) - , VersionP (..) - , ModuleNameP (..) - , PackageIdentifierRevision (..) - , pirForHash - , FileType (..) - , BuildFile (..) - , FileSize (..) - , TreeEntry (..) - , SafeFilePath - , unSafeFilePath - , mkSafeFilePath - , safeFilePathToPath - , hpackSafeFilePath - , TreeKey (..) - , Tree (..) - , renderTree - , parseTree - , parseTreeM - , SHA256 - , Unresolved - , resolvePaths - , Package (..) - , PackageCabal (..) - , PHpack (..) - -- , PackageTarball (..) - , RawPackageLocation (..) - , PackageLocation (..) - , toRawPL - , RawPackageLocationImmutable (..) - , PackageLocationImmutable (..) - , toRawPLI - , RawArchive (..) - , Archive (..) - , toRawArchive - , Repo (..) - , AggregateRepo (..) - , SimpleRepo (..) - , toAggregateRepos - , rToSimpleRepo - , arToSimpleRepo - , RepoType (..) - , parsePackageIdentifier - , parsePackageName - , parsePackageNameThrowing - , parseFlagName - , parseVersion - , parseVersionThrowing - , packageIdentifierString - , packageNameString - , flagNameString - , versionString - , moduleNameString - , OptionalSubdirs (..) - , ArchiveLocation (..) - , RelFilePath (..) - , CabalString (..) - , toCabalStringMap - , unCabalStringMap - , parsePackageIdentifierRevision - , Mismatch (..) - , PantryException (..) - , FuzzyResults (..) - , ResolvedPath (..) - , HpackExecutable (..) - , WantedCompiler (..) - --, resolveSnapshotLocation - , snapshotLocation - , defaultSnapshotLocation - , SnapName (..) - , parseSnapName - , RawSnapshotLocation (..) - , SnapshotLocation (..) - , toRawSL - , parseHackageText - , parseRawSnapshotLocation - , RawSnapshotLayer (..) - , SnapshotLayer (..) - , toRawSnapshotLayer - , RawSnapshot (..) - , Snapshot (..) - , RawSnapshotPackage (..) - , SnapshotPackage (..) - , parseWantedCompiler - , RawPackageMetadata (..) - , PackageMetadata (..) - , toRawPM - , cabalFileName - , SnapshotCacheHash (..) - , getGlobalHintsFile - , bsToBlobKey - , warnMissingCabalFile - , connRDBMS - ) where - -import Casa.Client ( CasaRepoPrefix ) -import Data.Aeson.Encoding.Internal ( unsafeToEncoding ) -import Data.Aeson.Types ( Parser, toJSONKeyText ) -import Data.ByteString.Builder - ( byteString, toLazyByteString, wordDec ) -import qualified Data.List.NonEmpty as NE -import Data.Text.Read ( decimal ) -import Distribution.CabalSpecVersion ( cabalSpecLatest ) -#if MIN_VERSION_Cabal(3,4,0) -import Distribution.CabalSpecVersion ( cabalSpecToVersionDigits ) -#else -import Distribution.CabalSpecVersion ( CabalSpecVersion (..) ) -#endif -import Distribution.ModuleName ( ModuleName ) -import Distribution.PackageDescription - ( FlagName, GenericPackageDescription, unFlagName ) -import Distribution.Parsec - ( PError (..), PWarning (..), ParsecParser - , explicitEitherParsec, parsec, showPos - ) -import qualified Distribution.Pretty -import qualified Distribution.Text -import Distribution.Types.PackageId ( PackageIdentifier (..) ) -import Distribution.Types.PackageName - ( PackageName, mkPackageName, unPackageName ) -import Distribution.Types.Version ( Version, mkVersion, nullVersion ) -import Distribution.Types.VersionRange ( VersionRange ) -import qualified Data.Conduit.Tar as Tar -import qualified Data.Map.Strict as Map ( mapKeysMonotonic ) -import Database.Persist -import Database.Persist.Sql -#if MIN_VERSION_persistent(2, 13, 0) -import Database.Persist.SqlBackend.Internal ( connRDBMS ) -#endif -import qualified Distribution.Compat.CharParsing as Parse -import qualified Hpack.Config as Hpack -import Network.HTTP.Client ( parseRequest ) -import Network.HTTP.Types ( Status, statusCode ) -import Pantry.Internal.AesonExtended - ( FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..) - , Object, ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..) - , Value (..), WarningParser, WithJSONWarnings, (..:), (..:?) - , (..!=), (.=), (.:), (...:?), jsonSubWarnings - , jsonSubWarningsT, noJSONWarnings, object, tellJSONField - , withObject, withObjectWarnings, withText - ) -import Pantry.SHA256 ( SHA256 ) -import qualified Pantry.SHA256 as SHA256 -import Path - ( Abs, Dir, File, Path, (), filename, parseRelFile - , toFilePath - ) -import Path.IO ( resolveDir, resolveFile ) -import qualified RIO.Set as Set -import RIO -import qualified RIO.ByteString as B -import qualified RIO.ByteString.Lazy as BL -import RIO.List ( groupBy, intersperse ) -import qualified RIO.Text as T -import RIO.Time ( Day, UTCTime, toGregorian ) -import qualified RIO.Map as Map -import RIO.PrettyPrint - ( bulletedList, fillSep, flow, hang, line, mkNarrativeList - , parens, string, style - ) -import RIO.PrettyPrint.Types ( Style (..) ) -import Text.PrettyPrint.Leijen.Extended ( Pretty (..), StyleDoc ) - -#if MIN_VERSION_aeson(2, 0, 0) -import qualified Data.Aeson.KeyMap as HM -import qualified Data.Aeson.Key - -type AesonKey = Data.Aeson.Key.Key -#else -import qualified RIO.HashMap as HM - -type AesonKey = Text -#endif - --- | Parsed tree with more information on the Haskell package it contains. --- --- @since 0.1.0.0 -data Package = Package - { packageTreeKey :: !TreeKey - -- ^ The 'TreeKey' containing this package. - -- - -- This is a hash of the binary representation of 'packageTree'. - -- - -- @since 0.1.0.0 - , packageTree :: !Tree - -- ^ The 'Tree' containing this package. - -- - -- @since 0.1.0.0 - , packageCabalEntry :: !PackageCabal - -- ^ Information on the cabal file inside this package. - -- - -- @since 0.1.0.0 - , packageIdent :: !PackageIdentifier - -- ^ The package name and version in this package. - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Ord) - -data PHpack = PHpack - { phOriginal :: !TreeEntry - -- ^ Original hpack file - , phGenerated :: !TreeEntry - -- ^ Generated Cabal file - , phVersion :: !Version - -- ^ Version of Hpack used - } - deriving (Show, Eq, Ord) - -data PackageCabal - = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file - | PCHpack !PHpack - deriving (Show, Eq, Ord) - -cabalFileName :: PackageName -> SafeFilePath -cabalFileName name = - case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of - Nothing -> error $ "cabalFileName: failed for " ++ show name - Just sfp -> sfp - --- | The revision number of a package from Hackage, counting upwards from 0 (the --- original cabal file). --- --- See caveats on 'CFIRevision'. --- --- @since 0.1.0.0 -newtype Revision = Revision Word - deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql) - --- | Represents a SQL database connection. This used to be a newtype wrapper --- around a connection pool. However, when investigating --- , it appeared that --- holding a pool resulted in overly long write locks being held on the --- database. As a result, we now abstract away whether a pool is used, and the --- default implementation in "Pantry.Storage" does not use a pool. -data Storage = Storage - { withStorage_ :: - forall env a. HasLogFunc env - => ReaderT SqlBackend (RIO env) a - -> RIO env a - , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a - } - --- | Configuration value used by the entire pantry package. Create one using --- 'withPantryConfig' or 'withPantryConfig''. See also 'PantryApp' for a --- convenience approach to using pantry. --- --- @since 0.1.0.0 -data PantryConfig = PantryConfig - { pcPackageIndex :: !PackageIndexConfig - , 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 - , pcCasaConfig :: !(Maybe (CasaRepoPrefix, Int)) - -- ^ Optionally, the Casa pull URL e.g. @https://casa.fpcomplete.com@ and - -- the maximum number of Casa keys to pull per request. - , pcSnapshotLocation :: SnapName -> RawSnapshotLocation - -- ^ The location of snapshot synonyms - } - --- | Get the location of a snapshot synonym from the 'PantryConfig'. --- --- @since 0.5.0.0 -snapshotLocation :: - HasPantryConfig env - => SnapName - -> RIO env RawSnapshotLocation -snapshotLocation name = do - loc <- view $ pantryConfigL.to pcSnapshotLocation - pure $ loc name - --- | Should we print warnings when loading a cabal file? --- --- @since 0.1.0.0 -data PrintWarnings = YesPrintWarnings | NoPrintWarnings - --- | Wraps a value which potentially contains relative paths. Needs to be --- provided with a base directory to resolve these paths. --- --- Unwrap this using 'resolvePaths'. --- --- @since 0.1.0.0 -newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) - deriving Functor - -instance Applicative Unresolved where - pure = Unresolved . const . pure - Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir - --- | Resolve all of the file paths in an 'Unresolved' relative to the given --- directory. --- --- @since 0.1.0.0 -resolvePaths :: - MonadIO m - => Maybe (Path Abs Dir) -- ^ directory to use for relative paths - -> Unresolved a - -> m a -resolvePaths mdir (Unresolved f) = liftIO (f mdir) - --- | A combination of the relative path provided in a config file, together with --- the resolved absolute path. --- --- @since 0.1.0.0 -data ResolvedPath t = ResolvedPath - { resolvedRelative :: !RelFilePath - -- ^ Original value parsed from a config file. - , resolvedAbsolute :: !(Path Abs t) - -- ^ Absolute path resolved against base directory loaded from. - } - deriving (Show, Eq, Generic, Ord) - -instance NFData (ResolvedPath t) - --- | Location to load a package from. Can either be immutable (see --- 'PackageLocationImmutable') or a local directory which is expected to change --- over time. Raw version doesn't include exact package version (e.g. could --- refer to the latest revision on Hackage) --- --- @since 0.1.0.0 -data RawPackageLocation - = RPLImmutable !RawPackageLocationImmutable - | RPLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Generic) - -instance NFData RawPackageLocation - --- | Location to load a package from. Can either be immutable (see --- 'PackageLocationImmutable') or a local directory which is expected to change --- over time. --- --- @since 0.1.0.0 -data PackageLocation - = PLImmutable !PackageLocationImmutable - | PLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Generic) - -instance NFData PackageLocation - -instance Display PackageLocation where - display (PLImmutable loc) = display loc - display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp - --- | Convert `PackageLocation` to its "raw" equivalent --- --- @since 0.1.0.0 -toRawPL :: PackageLocation -> RawPackageLocation -toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im) -toRawPL (PLMutable m) = RPLMutable m - --- | Location for remote packages or archives assumed to be immutable. --- as user specifies it i.e. not an exact location --- --- @since 0.1.0.0 -data RawPackageLocationImmutable - = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey) - | RPLIArchive !RawArchive !RawPackageMetadata - | RPLIRepo !Repo !RawPackageMetadata - deriving (Show, Eq, Ord, Generic) - -instance NFData RawPackageLocationImmutable - -instance Display RawPackageLocationImmutable where - display (RPLIHackage pir _tree) = display pir <> " (from Hackage)" - display (RPLIArchive archive _pm) = - "Archive from " <> display (raLocation archive) <> - (if T.null $ raSubdir archive - then mempty - else " in subdir " <> display (raSubdir archive)) - display (RPLIRepo repo _pm) = - "Repo from " <> display (repoUrl repo) <> - ", commit " <> display (repoCommit repo) <> - (if T.null $ repoSubdir repo - then mempty - else " in subdir " <> display (repoSubdir repo)) - -instance Pretty RawPackageLocationImmutable where - pretty (RPLIHackage pir _tree) = fillSep - [ fromString . T.unpack $ textDisplay pir - , parens (flow "from Hackage") - ] - pretty (RPLIArchive archive _pm) = fillSep - [ flow "Archive from" - , pretty (raLocation archive) - , if T.null $ raSubdir archive - then mempty - else fillSep - [ flow "in subdir" - , style Dir (fromString $ T.unpack (raSubdir archive)) - ] - ] - pretty (RPLIRepo repo _pm) = fillSep - [ flow "Repo from" - , style Url (fromString $ T.unpack (repoUrl repo)) <> "," - , "commit" - , fromString $ T.unpack (repoCommit repo) - , if T.null $ repoSubdir repo - then mempty - else fillSep - [ flow "in subdir" - , style Dir (fromString $ T.unpack (repoSubdir repo)) - ] - ] - --- | Location for remote packages or archives assumed to be immutable. --- --- @since 0.1.0.0 -data PackageLocationImmutable - = PLIHackage !PackageIdentifier !BlobKey !TreeKey - | PLIArchive !Archive !PackageMetadata - | PLIRepo !Repo !PackageMetadata - deriving (Generic, Show, Eq, Ord, Typeable) - -instance NFData PackageLocationImmutable - -instance Display PackageLocationImmutable where - display (PLIHackage ident _cabalHash _tree) = - fromString (packageNameString $ pkgName ident) <> " (from Hackage)" - display (PLIArchive archive _pm) = - "Archive from " <> display (archiveLocation archive) <> - (if T.null $ archiveSubdir archive - then mempty - else " in subdir " <> display (archiveSubdir archive)) - display (PLIRepo repo _pm) = - "Repo from " <> display (repoUrl repo) <> - ", commit " <> display (repoCommit repo) <> - (if T.null $ repoSubdir repo - then mempty - else " in subdir " <> display (repoSubdir repo)) - -instance ToJSON PackageLocationImmutable where - toJSON = toJSON . toRawPLI - --- | Package identifier and revision with a specified cabal file hash --- --- @since 0.1.0.0 -pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision -pirForHash (PackageIdentifier name ver) (BlobKey sha size') = - let cfi = CFIHash sha (Just size') - in PackageIdentifierRevision name ver cfi - --- | Convert `PackageLocationImmutable` to its "raw" equivalent --- --- @since 0.1.0.0 -toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable -toRawPLI (PLIHackage ident cfKey treeKey) = - RPLIHackage (pirForHash ident cfKey) (Just treeKey) -toRawPLI (PLIArchive archive pm) = - RPLIArchive (toRawArchive archive) (toRawPM pm) -toRawPLI (PLIRepo repo pm) = RPLIRepo repo (toRawPM pm) - --- | A raw package archive, specified by a user, could have no --- hash and file size information. --- --- @since 0.1.0.0 -data RawArchive = RawArchive - { raLocation :: !ArchiveLocation - -- ^ Location of the archive - -- - -- @since 0.1.0.0 - , raHash :: !(Maybe SHA256) - -- ^ Cryptographic hash of the archive file - -- - -- @since 0.1.0.0 - , raSize :: !(Maybe FileSize) - -- ^ Size of the archive file - -- - -- @since 0.1.0.0 - , raSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 - } - deriving (Generic, Show, Eq, Ord, Typeable) - -instance NFData RawArchive - --- | A package archive, could be from a URL or a local file path. Local file --- path archives are assumed to be unchanging over time, and so are allowed in --- custom snapshots. --- --- @since 0.1.0.0 -data Archive = Archive - { archiveLocation :: !ArchiveLocation - -- ^ Location of the archive - -- - -- @since 0.1.0.0 - , archiveHash :: !SHA256 - -- ^ Cryptographic hash of the archive file - -- - -- @since 0.1.0.0 - , archiveSize :: !FileSize - -- ^ Size of the archive file - -- - -- @since 0.1.0.0 - , archiveSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 - } - deriving (Generic, Show, Eq, Ord, Typeable) - -instance NFData Archive - --- | Convert archive to its "raw" equivalent. --- --- @since 0.1.0.0 -toRawArchive :: Archive -> RawArchive -toRawArchive archive = - RawArchive (archiveLocation archive) (Just $ archiveHash archive) - (Just $ archiveSize archive) (archiveSubdir archive) - --- | The type of a source control repository. --- --- @since 0.1.0.0 -data RepoType = RepoGit | RepoHg - deriving (Generic, Show, Eq, Ord, Typeable) - -instance NFData RepoType - -instance PersistField RepoType where - toPersistValue RepoGit = toPersistValue (1 :: Int32) - toPersistValue RepoHg = toPersistValue (2 :: Int32) - fromPersistValue v = do - i <- fromPersistValue v - case i :: Int32 of - 1 -> pure RepoGit - 2 -> pure RepoHg - _ -> Left $ fromString $ "Invalid RepoType: " ++ show i - -instance PersistFieldSql RepoType where - sqlType _ = SqlInt32 - --- | Information on packages stored in a source control repository. --- --- @since 0.1.0.0 -data Repo = Repo - { repoUrl :: !Text - -- ^ Location of the repo - -- - -- @since 0.1.0.0 - , repoCommit :: !Text - -- ^ Commit to use from the repo. It's strongly recommended to use - -- a hash instead of a tag or branch name. - -- - -- @since 0.1.0.0 - , repoType :: !RepoType - -- ^ The type of the repo - -- - -- @since 0.1.0.0 - , repoSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 - } - deriving (Generic, Eq, Ord, Typeable) - -instance NFData Repo - -instance Show Repo where - show = T.unpack . utf8BuilderToText . display - -instance Display Repo where - display (Repo url commit typ subdir) = - (case typ of - RepoGit -> "Git" - RepoHg -> "Mercurial") <> - " repo at " <> - display url <> - ", commit " <> - display commit <> - (if T.null subdir - then mempty - else " in subdirectory " <> display subdir) - -rToSimpleRepo :: Repo -> SimpleRepo -rToSimpleRepo Repo {..} = SimpleRepo - { sRepoUrl = repoUrl - , sRepoCommit = repoCommit - , sRepoType = repoType - } - -data AggregateRepo = AggregateRepo - { aRepo :: !SimpleRepo - , aRepoSubdirs :: [(Text, RawPackageMetadata)] - } - deriving (Show, Generic, Eq, Ord, Typeable) - --- | Group input repositories by non-subdir values. -toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo] -toAggregateRepos = mapMaybe toAggregateRepo . groupBy matchRepoExclSubdir - where - toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo - toAggregateRepo [] = Nothing - toAggregateRepo xs@((repo, _):_) = - Just $ AggregateRepo (rToSimpleRepo repo) (fmap (first repoSubdir) xs) - - matchRepoExclSubdir x1 x2 = - let (Repo url1 commit1 type1 _, _) = x1 - (Repo url2 commit2 type2 _, _) = x2 - in (url1, commit1, type1) == (url2, commit2, type2) - -arToSimpleRepo :: AggregateRepo -> SimpleRepo -arToSimpleRepo AggregateRepo {..} = aRepo - --- | Repository without subdirectory information. --- --- @since 0.5.3 -data SimpleRepo = SimpleRepo - { sRepoUrl :: !Text - , sRepoCommit :: !Text - , sRepoType :: !RepoType - } - deriving (Show, Generic, Eq, Ord, Typeable) - -instance Display SimpleRepo where - display (SimpleRepo url commit typ) = - (case typ of - RepoGit -> "Git" - RepoHg -> "Mercurial") <> - " repo at " <> - display url <> - ", commit " <> - display commit - --- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains --- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". -newtype GitHubRepo = GitHubRepo Text - -instance FromJSON GitHubRepo where - parseJSON = withText "GitHubRepo" $ \s -> do - case T.split (== '/') s of - [x, y] | not (T.null x || T.null y) -> pure (GitHubRepo s) - _ -> fail "expecting \"user/repo\"" - --- | Configuration to securely download package metadata and contents. For most --- purposes, you'll want to use the default Hackage settings via --- @defaultPackageIndexConfig@. --- --- /NOTE/ It's highly recommended to only use the official Hackage --- server or a mirror. See --- . --- --- @since 0.6.0 -data PackageIndexConfig = PackageIndexConfig - { picDownloadPrefix :: !Text - , picHackageSecurityConfig :: !HackageSecurityConfig - } - deriving Show - --- | If the @hackage-security@ key is absent from the JSON object, assigns --- default value 'defaultHackageSecurityConfig'. --- --- @since 0.6.0 -instance FromJSON (WithJSONWarnings PackageIndexConfig) where - parseJSON = withObjectWarnings "PackageIndexConfig" $ \o -> do - picDownloadPrefix <- o ..: "download-prefix" - picHackageSecurityConfig <- jsonSubWarnings $ - o ..:? "hackage-security" ..!= noJSONWarnings defaultHackageSecurityConfig - pure PackageIndexConfig {..} - --- | Default 'HackageSecurityConfig' value using the official Hackage server. --- The value of the 'hscIgnoreExpiry' field is 'True'. --- --- @since 0.7.0 -defaultHackageSecurityConfig :: HackageSecurityConfig -defaultHackageSecurityConfig = HackageSecurityConfig - { hscKeyIds = - [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" - , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" - , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" - , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" - , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" - ] - , hscKeyThreshold = 3 - , hscIgnoreExpiry = True - } - --- | Configuration for Hackage Security to securely download package metadata --- and contents. 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.6.0 -data HackageSecurityConfig = HackageSecurityConfig - { hscKeyIds :: ![Text] - , hscKeyThreshold :: !Int - , hscIgnoreExpiry :: !Bool - } - deriving Show - --- | If the @ignore-expiry@ key is absent from the JSON object, assigns default --- value 'True'. --- --- @since 0.1.1.0 -instance FromJSON (WithJSONWarnings HackageSecurityConfig) where - parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o -> do - hscKeyIds <- o ..: "keyids" - hscKeyThreshold <- o ..: "key-threshold" - hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True - pure HackageSecurityConfig {..} - --- | An environment which contains a 'PantryConfig'. --- --- @since 0.1.0.0 -class HasPantryConfig env where - -- | Lens to get or set the 'PantryConfig' - -- - -- @since 0.1.0.0 - pantryConfigL :: Lens' env PantryConfig - - --- | File size in bytes --- --- @since 0.1.0.0 -newtype FileSize = FileSize Word - deriving ( Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData - , PersistField, PersistFieldSql, ToJSON, FromJSON - ) - --- | A key for looking up a blob, which combines the SHA256 hash of the contents --- and the file size. --- --- The file size may seem redundant with the hash. However, it is necessary for --- safely downloading blobs from an untrusted source. See --- . --- --- @since 0.1.0.0 -data BlobKey = BlobKey !SHA256 !FileSize - deriving (Eq, Ord, Typeable, Generic) - -instance NFData BlobKey - -instance Show BlobKey where - show = T.unpack . utf8BuilderToText . display - -instance Display BlobKey where - display (BlobKey sha size') = display sha <> "," <> display size' - -blobKeyPairs :: BlobKey -> [(AesonKey, Value)] -blobKeyPairs (BlobKey sha size') = - [ "sha256" .= sha - , "size" .= size' - ] - -instance ToJSON BlobKey where - toJSON = object . blobKeyPairs - -instance FromJSON BlobKey where - parseJSON = withObject "BlobKey" $ \o -> BlobKey - <$> o .: "sha256" - <*> o .: "size" - -newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } - deriving (Eq, Ord, Show, Read, NFData) - -instance Display PackageNameP where - display = fromString . packageNameString . unPackageNameP - -instance PersistField PackageNameP where - toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn - fromPersistValue v = do - str <- fromPersistValue v - case parsePackageName str of - Nothing -> Left $ "Invalid package name: " <> T.pack str - Just pn -> Right $ PackageNameP pn - -instance PersistFieldSql PackageNameP where - sqlType _ = SqlString - -instance ToJSON PackageNameP where - toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn - -instance FromJSON PackageNameP where - parseJSON = - withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack - -instance ToJSONKey PackageNameP where - toJSONKey = - ToJSONKeyText - (fromString . packageNameString . unPackageNameP) - (unsafeToEncoding . getUtf8Builder . display) - -instance FromJSONKey PackageNameP where - fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack - -newtype VersionP = VersionP { unVersionP :: Version } - deriving (Eq, Ord, Show, Read, NFData) - -instance PersistField VersionP where - toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v - fromPersistValue v = do - str <- fromPersistValue v - case parseVersion str of - Nothing -> Left $ "Invalid version number: " <> T.pack str - Just ver -> Right $ VersionP ver - -instance PersistFieldSql VersionP where - sqlType _ = SqlString - -instance Display VersionP where - display (VersionP v) = fromString $ versionString v - -instance ToJSON VersionP where - toJSON (VersionP v) = String $ T.pack $ versionString v - -instance FromJSON VersionP where - parseJSON = - withText "VersionP" $ - either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack - -newtype ModuleNameP = ModuleNameP - { unModuleNameP :: ModuleName - } - deriving (Eq, Ord, Show, NFData) - -instance Display ModuleNameP where - display = fromString . moduleNameString . unModuleNameP - -instance PersistField ModuleNameP where - toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn - fromPersistValue v = do - str <- fromPersistValue v - case parseModuleName str of - Nothing -> Left $ "Invalid module name: " <> T.pack str - Just pn -> Right $ ModuleNameP pn - -instance PersistFieldSql ModuleNameP where - sqlType _ = SqlString - --- | How to choose a cabal file for a package from Hackage. This is to work with --- Hackage cabal file revisions, which makes @PackageIdentifier@ insufficient --- for specifying a package from Hackage. --- --- @since 0.1.0.0 -data CabalFileInfo - = CFILatest - -- ^ Take the latest revision of the cabal file available. This - -- isn't reproducible at all, but the running assumption (not - -- necessarily true) is that cabal file revisions do not change - -- semantics of the build. - -- - -- @since 0.1.0.0 - | CFIHash !SHA256 !(Maybe FileSize) - -- ^ Identify by contents of the cabal file itself. Only reason for - -- @Maybe@ on @FileSize@ is for compatibility with input that - -- doesn't include the file size. - -- - -- @since 0.1.0.0 - | CFIRevision !Revision - -- ^ Identify by revision number, with 0 being the original and - -- counting upward. This relies on Hackage providing consistent - -- versioning. @CFIHash@ should be preferred wherever possible for - -- reproducibility. - -- - -- @since 0.1.0.0 - deriving (Generic, Show, Eq, Ord, Typeable) - -instance NFData CabalFileInfo - -instance Hashable CabalFileInfo - -instance Display CabalFileInfo where - display CFILatest = mempty - display (CFIHash hash' msize) = - "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize - display (CFIRevision rev) = "@rev:" <> display rev - --- | A full specification for a package from Hackage, including the package --- name, version, and how to load up the correct cabal file revision. --- --- @since 0.1.0.0 -data PackageIdentifierRevision - = PackageIdentifierRevision !PackageName !Version !CabalFileInfo - deriving (Generic, Eq, Ord, Typeable) - -instance NFData PackageIdentifierRevision - -instance Show PackageIdentifierRevision where - show = T.unpack . utf8BuilderToText . display - -instance Display PackageIdentifierRevision where - display (PackageIdentifierRevision name version cfi) = - fromString (packageNameString name) - <> "-" - <> fromString (versionString version) - <> display cfi - -instance ToJSON PackageIdentifierRevision where - toJSON = toJSON . utf8BuilderToText . display - -instance FromJSON PackageIdentifierRevision where - parseJSON = withText "PackageIdentifierRevision" $ \t -> - case parsePackageIdentifierRevision t of - Left e -> fail $ show e - Right pir -> pure pir - --- | Parse a hackage text. --- --- @since 0.1.0.0 -parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) -parseHackageText t = - either (\x -> error (show x) $ const $ Left $ PackageIdentifierRevisionParseFail t) Right $ - explicitEitherParsec (hackageTextParsec <* Parse.eof) $ - T.unpack t - -hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey) -hackageTextParsec = do - ident <- packageIdentifierParsec - _ <- Parse.string "@sha256:" - - shaT <- Parse.munch (/= ',') - sha <- either (const mzero) pure $ SHA256.fromHexText $ fromString shaT - - _ <- Parse.char ',' - size' <- Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't - pure (ident, BlobKey sha (FileSize size')) - -splitColon :: Text -> Maybe (Text, Text) -splitColon t' = - let (x, y) = T.break (== ':') t' - in (x, ) <$> T.stripPrefix ":" y - --- | Parse a 'PackageIdentifierRevision' --- --- @since 0.1.0.0 -parsePackageIdentifierRevision :: - Text - -> Either PantryException PackageIdentifierRevision -parsePackageIdentifierRevision t = - maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do - let (identT, cfiT) = T.break (== '@') t - PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT - cfi <- - case splitColon cfiT of - Just ("@sha256", shaSizeT) -> do - let (shaT, sizeT) = T.break (== ',') shaSizeT - sha <- either (const Nothing) Just $ SHA256.fromHexText shaT - msize <- - case T.stripPrefix "," sizeT of - Nothing -> Just Nothing - Just sizeT' -> - case decimal sizeT' of - Right (size', "") -> Just $ Just $ FileSize size' - _ -> Nothing - pure $ CFIHash sha msize - Just ("@rev", revT) -> - case decimal revT of - Right (rev, "") -> pure $ CFIRevision $ Revision rev - _ -> Nothing - Nothing -> pure CFILatest - _ -> Nothing - pure $ PackageIdentifierRevision name version cfi - -data Mismatch a = Mismatch - { mismatchExpected :: !a - , mismatchActual :: !a - } - --- | Things that can go wrong in pantry. Note two things: --- --- * Many other exception types may be thrown from underlying libraries. Pantry --- does not attempt to wrap these underlying exceptions. --- --- * We may add more constructors to this data type in minor version bumps of --- pantry. This technically breaks the PVP. You should not be writing pattern --- matches against this type that expect total matching. --- --- @since 0.1.0.0 -data PantryException - = PackageIdentifierRevisionParseFail !Text - | InvalidCabalFile - !(Either RawPackageLocationImmutable (Path Abs File)) - !(Maybe Version) - ![PError] - ![PWarning] - | TreeWithoutCabalFile !RawPackageLocationImmutable - | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath] - | MismatchedCabalName !(Path Abs File) !PackageName - | NoLocalPackageDirFound !(Path Abs Dir) - | NoCabalFileFound !(Path Abs Dir) - | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] - | InvalidWantedCompiler !Text - | InvalidSnapshotLocation !(Path Abs Dir) !Text - | InvalidOverrideCompiler !WantedCompiler !WantedCompiler - | InvalidFilePathSnapshot !Text - | InvalidSnapshot !RawSnapshotLocation !SomeException - | MismatchedPackageMetadata - !RawPackageLocationImmutable - !RawPackageMetadata - !(Maybe TreeKey) - !PackageIdentifier - | Non200ResponseStatus !Status - | InvalidBlobKey !(Mismatch BlobKey) - | Couldn'tParseSnapshot !RawSnapshotLocation !String - | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName - | DownloadInvalidSHA256 !Text !(Mismatch SHA256) - | DownloadInvalidSize !Text !(Mismatch FileSize) - | DownloadTooLarge !Text !(Mismatch FileSize) - -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is - -- a lower bound on the size from the server. - | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256) - | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize) - | UnknownArchiveType !ArchiveLocation - | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType - | UnsupportedTarball !ArchiveLocation !Text - | NoHackageCryptographicHash !PackageIdentifier - | FailedToCloneRepo !SimpleRepo - | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey - | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata - | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32) - | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults - | CannotCompleteRepoNonSHA1 !Repo - | MutablePackageLocationFromUrl !Text - | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) - | PackageNameParseFail !Text - | PackageVersionParseFail !Text - | InvalidCabalFilePath !(Path Abs File) - | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])] - | MigrationFailure !Text !(Path Abs File) !SomeException - | NoCasaConfig - | InvalidTreeFromCasa !BlobKey !ByteString - | ParseSnapNameException !Text - | HpackLibraryException !(Path Abs File) !String - | HpackExeException !FilePath !(Path Abs Dir) !SomeException - deriving Typeable - -instance Exception PantryException where - -instance Show PantryException where - show = T.unpack . utf8BuilderToText . display - --- To support the Haskell Foundation's --- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry --- error messages generated by Pantry itself begin with an unique code in the --- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999. --- The numbers are selected at random, not in sequence. --- --- Prettier versions of these error messages are also provided. See the instance --- of Pretty. -instance Display PantryException where - display NoCasaConfig = - "Error: [S-889]\n" - <> "The Pantry configuration has no Casa configuration." - display (InvalidTreeFromCasa blobKey _bs) = - "Error: [S-258]\n" - <> "Invalid tree from casa: " - <> display blobKey - display (PackageIdentifierRevisionParseFail text) = - "Error: [S-360]\n" - <> "Invalid package identifier (with optional revision): " - <> display text - display (InvalidCabalFile loc mversion errs warnings) = - "Error: [S-242]\n" - <> "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) = - "Error: [S-654]\n" - <> "No cabal file found for " - <> display pl - display (TreeWithMultipleCabalFiles pl sfps) = - "Error: [S-500]\n" - <> "Multiple cabal files found for " - <> display pl - <> ": " - <> fold (intersperse ", " (map display sfps)) - display (MismatchedCabalName fp name) = - "Error: [S-910]\n" - <> "The Cabal file:\n" - <> fromString (toFilePath fp) - <> "\nis not named after the package that it defines.\n" - <> "Please rename the file to: " - <> fromString (packageNameString name) - <> ".cabal\n" - <> "Hackage rejects packages where the first part of the Cabal file name " - <> "is not the package name." - display (NoLocalPackageDirFound dir) = - "Error: [S-395]\n" - <> "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 such directory could be found. If, alternatively, a package\n" - <> "in the package index was intended, its name and version must be\n" - <> "specified as an extra-dep." - display (NoCabalFileFound dir) = - "Error: [S-636]\n" - <> "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) = - "Error: [S-368]\n" - <> "Multiple .cabal files found in directory " - <> fromString (toFilePath dir) - <> ":\n" - <> fold - ( intersperse - "\n" - (map (\x -> "- " <> fromString (toFilePath (filename x))) files) - ) - display (InvalidWantedCompiler t) = - "Error: [S-204]\n" - <> "Invalid wanted compiler: " - <> display t - display (InvalidSnapshotLocation dir t) = - "Error: [S-935]\n" - <> "Invalid snapshot location " - <> displayShow t - <> " relative to directory " - <> displayShow (toFilePath dir) - display (InvalidOverrideCompiler x y) = - "Error: [S-287]\n" - <> "Specified compiler for a resolver (" - <> display x - <> "), but also specified an override compiler (" - <> display y - <> ")" - display (InvalidFilePathSnapshot t) = - "Error: [S-617]\n" - <> "Specified snapshot as file path with " - <> displayShow t - <> ", but not reading from a local file" - display (InvalidSnapshot loc err) = - "Error: [S-775]\n" - <> "Exception while reading snapshot from " - <> display loc - <> ":\n" - <> displayShow err - display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = - "Error: [S-427]\n" - <> "Mismatched package metadata for " - <> display loc - <> "\nFound: " - <> fromString (packageIdentifierString foundIdent) - <> ( case mtreeKey of - Nothing -> mempty - Just treeKey -> " with tree " <> display treeKey - ) - <> "\nExpected: " - <> display pm - display (Non200ResponseStatus status) = - "Error: [S-571]\n" - <> "Unexpected non-200 HTTP status code: " - <> displayShow (statusCode status) - display (InvalidBlobKey Mismatch{..}) = - "Error: [S-236]\n" - <> "Invalid blob key found, expected: " - <> display mismatchExpected - <> ", actual: " - <> display mismatchActual - display (Couldn'tParseSnapshot sl err) = - "Error: [S-645]\n" - <> "Couldn't parse snapshot from " - <> display sl - <> ": " - <> fromString err - display (WrongCabalFileName pl sfp name) = - "Error: [S-575]\n" - <> "Wrong cabal file name for package " - <> display pl - <> "\nThe cabal file is named " - <> display sfp - <> ", but package name is " - <> fromString (packageNameString name) - <> "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" - display (DownloadInvalidSHA256 url Mismatch {..}) = - "Error: [S-394]\n" - <> "Mismatched SHA256 hash from " - <> display url - <> "\nExpected: " - <> display mismatchExpected - <> "\nActual: " - <> display mismatchActual - display (DownloadInvalidSize url Mismatch {..}) = - "Error: [S-401]\n" - <> "Mismatched download size from " - <> display url - <> "\nExpected: " - <> display mismatchExpected - <> "\nActual: " - <> display mismatchActual - display (DownloadTooLarge url Mismatch {..}) = - "Error: [S-113]\n" - <> "Download from " - <> display url - <> " was too large.\n" - <> "Expected: " - <> display mismatchExpected - <> ", stopped after receiving: " - <> display mismatchActual - display (LocalInvalidSHA256 path Mismatch {..}) = - "Error: [S-834]\n" - <> "Mismatched SHA256 hash from " - <> fromString (toFilePath path) - <> "\nExpected: " - <> display mismatchExpected - <> "\nActual: " - <> display mismatchActual - display (LocalInvalidSize path Mismatch {..}) = - "Error: [S-713]\n" - <> "Mismatched file size from " - <> fromString (toFilePath path) - <> "\nExpected: " - <> display mismatchExpected - <> "\nActual: " - <> display mismatchActual - display (UnknownArchiveType loc) = - "Error: [S-372]\n" - <> "Unable to determine archive type of: " - <> display loc - display (InvalidTarFileType loc fp x) = - "Error: [S-950]\n" - <> "Unsupported tar file type in archive " - <> display loc - <> " at file " - <> fromString fp - <> ": " - <> displayShow x - display (UnsupportedTarball loc err) = - "Error: [S-760]\n" - <> "Unsupported tarball from " - <> display loc - <> ": " - <> display err - display (NoHackageCryptographicHash ident) = - "Error: [S-922]\n" - <> "No cryptographic hash found for Hackage package " - <> fromString (packageIdentifierString ident) - display (FailedToCloneRepo repo) = - "Error: [S-109]\n" - <> "Failed to clone repo " - <> display repo - display (TreeReferencesMissingBlob loc sfp key) = - "Error: [S-237]\n" - <> "The package " - <> display loc - <> " needs blob " - <> display key - <> " for file path " - <> display sfp - <> ", but the blob is not available" - display (CompletePackageMetadataMismatch loc pm) = - "Error: [S-984]\n" - <> "When completing package metadata for " - <> display loc - <> ", some values changed in the new package metadata: " - <> display pm - display (CRC32Mismatch loc fp Mismatch {..}) = - "Error: [S-607]\n" - <> "CRC32 mismatch in ZIP file from " - <> display loc - <> " on internal file " - <> fromString fp - <> "\nExpected: " - <> display mismatchExpected - <> "\nActual: " - <> display mismatchActual - display (UnknownHackagePackage pir fuzzy) = - "Error: [S-476]\n" - <> "Could not find " - <> display pir - <> " on Hackage" - <> displayFuzzy fuzzy - display (CannotCompleteRepoNonSHA1 repo) = - "Error: [S-112]\n" - <> "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " - <> display repo - display (MutablePackageLocationFromUrl t) = - "Error: [S-321]\n" - <> "Cannot refer to a mutable package location from a URL: " - <> display t - display (MismatchedCabalFileForHackage pir Mismatch{..}) = - "Error: [S-377]\n" - <> "When processing cabal file for Hackage package " - <> display pir - <> ":\nMismatched package identifier." - <> "\nExpected: " - <> fromString (packageIdentifierString mismatchExpected) - <> "\nActual: " - <> fromString (packageIdentifierString mismatchActual) - display (PackageNameParseFail t) = - "Error: [S-580]\n" - <> "Invalid package name: " - <> display t - display (PackageVersionParseFail t) = - "Error: [S-479]\n" - <> "Invalid version: " - <> display t - display (InvalidCabalFilePath fp) = - "Error: [S-824]\n" - <> "File path contains a name which is not a valid package name: " - <> fromString (toFilePath fp) - display (DuplicatePackageNames source pairs') = - "Error: [S-674]\n" - <> "Duplicate package names (" - <> source - <> "):\n" - <> foldMap - ( \(name, locs) -> - fromString (packageNameString name) - <> ":\n" - <> foldMap (\loc -> "- " <> display loc <> "\n") locs - ) - pairs' - display (MigrationFailure desc fp err) = - "Error: [S-536]\n" - <> "Encountered error while migrating database " - <> display desc - <> "\nlocated at " - <> fromString (toFilePath fp) - <> ":" - <> "\n " - <> displayShow err - display (ParseSnapNameException t) = - "Error: [S-994]\n" - <> "Invalid snapshot name: " - <> display t - display (HpackLibraryException file err) = - "Error: [S-305]\n" - <> "Failed to generate a Cabal file using the Hpack library on file:\n" - <> fromString (toFilePath file) - <> "\n\n" - <> "The error encountered was:\n\n" - <> fromString err - display (HpackExeException fp dir err) = - "Error: [S-720]\n" - <> "Failed to generate a Cabal file using the Hpack executable:\n" - <> fromString fp - <> "in directory: " - <> fromString (toFilePath dir) - <> "\n\n" - <> "The error encountered was:\n\n" - <> fromString (show err) - --- See also the instance of Display. Although prettier, these messages are --- intended to be substantively the same as the corresponding 'black and white' --- versions. -instance Pretty PantryException where - pretty NoCasaConfig = - "[S-889]" - <> line - <> flow "The Pantry configuration has no Casa configuration." - pretty (InvalidTreeFromCasa blobKey _bs) = - "[S-258]" - <> line - <> fillSep - [ flow "Invalid tree from casa:" - , fromString . T.unpack $ textDisplay blobKey - ] - pretty (PackageIdentifierRevisionParseFail text) = - "[S-360]" - <> line - <> fillSep - [ flow "Invalid package identifier (with optional revision):" - , fromString $ T.unpack text - ] - pretty (InvalidCabalFile loc mversion errs warnings) = - "[S-242]" - <> line - <> fillSep - [ flow "Unable to parse Cabal file from package" - , either pretty pretty loc <> ":" - ] - <> line - <> bulletedList - ( map (\(PError pos msg) -> fillSep - [ fromString (showPos pos) <> ":" - , fromString msg - ]) - errs - ) - <> line - <> bulletedList - ( map (\(PWarning _ pos msg) -> fillSep - [ fromString (showPos pos) <> ":" - , fromString msg - ]) - warnings - ) - <> ( case mversion of - Just version | version > cabalSpecLatestVersion -> - line - <> fillSep - [ flow "The Cabal file uses the Cabal specification version" - , style Current (fromString $ versionString version) <> "," - , flow "but we only support up to version" - , fromString (versionString cabalSpecLatestVersion) <> "." - , flow "Recommended action: upgrade your build tool" - , parens (fillSep - [ "e.g." - , style Shell (flow "stack upgrade") - ]) <> "." - ] - _ -> mempty - ) - pretty (TreeWithoutCabalFile loc) = - "[S-654]" - <> line - <> fillSep - [ flow "No Cabal file found for" - , pretty loc <> "." - ] - pretty (TreeWithMultipleCabalFiles loc sfps) = - "[S-500]" - <> line - <> fillSep - ( flow "Multiple Cabal files found for" - : (pretty loc <> ":") - : mkNarrativeList (Just File) False - (map (fromString . T.unpack . textDisplay) sfps :: [StyleDoc]) - ) - pretty (MismatchedCabalName fp name) = - "[S-910]" - <> line - <> fillSep - [ flow "The Cabal file" - , pretty fp - , flow "is not named after the package that it defines. Please rename" - , flow "the file to" - , style File (fromString $ packageNameString name <> ".cabal") <> "." - , flow "Hackage rejects packages where the first part of the Cabal" - , flow "file name is not the package name." - ] - pretty (NoLocalPackageDirFound dir) = - "[S-395]" - <> line - <> fillSep - [ flow "Stack looks for packages in the directories configured in the" - , style Shell "packages" - , "and" - , style Shell "extra-deps" - , flow "fields defined in your" - , style File "stack.yaml" <> "." - , flow "The current entry points to" - , pretty dir - , flow "but no such directory could be found. If, alternatively, a" - , flow "package in the package index was intended, its name and" - , flow "version must be specified as an extra-dep." - ] - pretty (NoCabalFileFound dir) = - "[S-636]" - <> line - <> fillSep - [ flow "Stack looks for packages in the directories configured in the" - , style Shell "packages" - , "and" - , style Shell "extra-deps" - , flow "fields defined in your" - , style File "stack.yaml" <> "." - , flow "The current entry points to" - , pretty dir - , flow "but no Cabal file or" - , style File "package.yaml" - , flow "could be found there." - ] - pretty (MultipleCabalFilesFound dir files) = - "[S-368]" - <> line - <> fillSep - ( flow "Multiple Cabal files found in directory" - : (pretty dir <> ":") - : mkNarrativeList (Just File) False - (map (pretty . filename) files) - ) - pretty (InvalidWantedCompiler t) = - "[S-204]" - <> line - <> fillSep - [ flow "Invalid wanted compiler:" - , style Current (fromString $ T.unpack t) <> "." - ] - pretty (InvalidSnapshotLocation dir t) = - "[S-935]" - <> line - <> fillSep - [ flow "Invalid snapshot location" - , style Current (fromString $ T.unpack t) - , flow "relative to directory" - , pretty dir <> "." - ] - pretty (InvalidOverrideCompiler x y) = - "[S-287]" - <> line - <> fillSep - [ flow "Specified compiler for a resolver" - , parens (style Shell (fromString . T.unpack $ textDisplay x)) - , flow "but also specified an override compiler" - , parens (style Shell (fromString . T.unpack $ textDisplay y)) <> "." - ] - pretty (InvalidFilePathSnapshot t) = - "[S-617]" - <> line - <> fillSep - [ flow "Specified snapshot as file path with" - , style File (fromString $ T.unpack t) <> "," - , flow "but not reading from a local file." - ] - pretty (InvalidSnapshot loc err) = - "[S-775]" - <> line - <> fillSep - [ flow "Exception while reading snapshot from" - , pretty loc <> ":" - ] - <> blankLine - <> string (displayException err) - pretty (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = - "[S-427]" - <> line - <> fillSep - [ flow "Mismatched package metadata for" - , pretty loc <> "." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , let t = textDisplay pm - in if T.null t - then "nothing." - else fromString $ T.unpack t <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Found: " - , fromString $ packageIdentifierString foundIdent <> case mtreeKey of - Nothing -> "." - _ -> mempty - , case mtreeKey of - Nothing -> mempty - Just treeKey -> fillSep - [ "with tree" - , fromString . T.unpack $ textDisplay treeKey <> "." - ] - ]) - pretty (Non200ResponseStatus status) = - "[S-571]" - <> line - <> fillSep - [ flow "Unexpected non-200 HTTP status code:" - , (fromString . show $ statusCode status) <> "." - ] - pretty (InvalidBlobKey Mismatch{..}) = - "[S-236]" - <> line - <> fillSep - [ flow "Invalid blob key found, expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "," - , "actual:" - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ] - pretty (Couldn'tParseSnapshot sl err) = - "[S-645]" - <> line - <> fillSep - [ flow "Couldn't parse snapshot from" - , pretty sl <> ":" - ] - <> blankLine - <> string err - pretty (WrongCabalFileName loc sfp name) = - "[S-575]" - <> line - <> fillSep - [ flow "Wrong Cabal file name for package" - , pretty loc <> "." - , flow "The Cabal file is named" - , style File (fromString . T.unpack $ textDisplay sfp) <> "," - , flow "but package name is" - , fromString (packageNameString name) <> "." - , flow "For more information, see" - , style Url "https://github.com/commercialhaskell/stack/issues/317" - , "and" - , style Url "https://github.com/commercialhaskell/stack/issues/895" <> "." - ] - pretty (DownloadInvalidSHA256 url Mismatch {..}) = - "[S-394]" - <> line - <> fillSep - [ flow "Mismatched SHA256 hash from" - , style Url (fromString $ T.unpack url) <> "." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ]) - pretty (DownloadInvalidSize url Mismatch {..}) = - "[S-401]" - <> line - <> fillSep - [ flow "Mismatched download size from" - , style Url (fromString $ T.unpack url) <> "." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ]) - pretty (DownloadTooLarge url Mismatch {..}) = - "[S-113]" - <> line - <> fillSep - [ flow "Download from" - , style Url (fromString $ T.unpack url) - , flow "was too large. Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "," - , flow "stopped after receiving:" - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ] - pretty (LocalInvalidSHA256 path Mismatch {..}) = - "[S-834]" - <> line - <> fillSep - [ flow "Mismatched SHA256 hash from" - , pretty path <> "." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ]) - pretty (LocalInvalidSize path Mismatch {..}) = - "[S-713]" - <> line - <> fillSep - [ flow "Mismatched file size from" - , pretty path <> "." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ]) - pretty (UnknownArchiveType loc) = - "[S-372]" - <> line - <> fillSep - [ flow "Unable to determine archive type of:" - , pretty loc <> "." - ] - pretty (InvalidTarFileType loc fp x) = - "[S-950]" - <> line - <> fillSep - [ flow "Unsupported tar file type in archive" - , pretty loc - , flow "at file" - , style File (fromString fp) <> ":" - , fromString $ show x <> "." - ] - pretty (UnsupportedTarball loc err) = - "[S-760]" - <> line - <> fillSep - [ flow "Unsupported tarball from" - , pretty loc <> ":" - ] - <> blankLine - <> string (T.unpack err) - pretty (NoHackageCryptographicHash ident) = - "[S-922]" - <> line - <> fillSep - [ flow "No cryptographic hash found for Hackage package" - , fromString (packageIdentifierString ident) <> "." - ] - pretty (FailedToCloneRepo repo) = - "[S-109]" - <> line - <> fillSep - [ flow "Failed to clone repository" - , fromString . T.unpack $ textDisplay repo - ] - pretty (TreeReferencesMissingBlob loc sfp key) = - "[S-237]" - <> line - <> fillSep - [ flow "The package" - , pretty loc - , flow "needs blob" - , fromString . T.unpack $ textDisplay key - , flow "for file path" - , style File (fromString . T.unpack $ textDisplay sfp) <> "," - , flow "but the blob is not available." - ] - pretty (CompletePackageMetadataMismatch loc pm) = - "[S-984]" - <> line - <> fillSep - [ flow "When completing package metadata for" - , pretty loc <> "," - , flow "some values changed in the new package metadata:" - , fromString . T.unpack $ textDisplay pm <> "." - ] - pretty (CRC32Mismatch loc fp Mismatch {..}) = - "[S-607]" - <> line - <> fillSep - [ flow "CRC32 mismatch in Zip file from" - , pretty loc - , flow "on internal file" - , style File (fromString fp) - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ]) - pretty (UnknownHackagePackage pir fuzzy) = - "[S-476]" - <> line - <> fillSep - [ flow "Could not find" - , style Error (fromString . T.unpack $ textDisplay pir) - , flow "on Hackage." - ] - <> prettyFuzzy fuzzy - pretty (CannotCompleteRepoNonSHA1 repo) = - "[S-112]" - <> line - <> fillSep - [ flow "Cannot complete repo information for a non SHA1 commit due to" - , "non-reproducibility:" - , fromString . T.unpack $ textDisplay repo <> "." - ] - pretty (MutablePackageLocationFromUrl t) = - "[S-321]" - <> line - <> fillSep - [ flow "Cannot refer to a mutable package location from a URL:" - , style Url (fromString $ T.unpack t) <> "." - ] - pretty (MismatchedCabalFileForHackage pir Mismatch{..}) = - "[S-377]" - <> line - <> fillSep - [ flow "When processing Cabal file for Hackage package" - , fromString . T.unpack $ textDisplay pir <> "," - , flow "mismatched package identifier." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString (packageIdentifierString mismatchExpected) <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString (packageIdentifierString mismatchActual) <> "." - ]) - pretty (PackageNameParseFail t) = - "[S-580]" - <> line - <> fillSep - [ flow "Invalid package name:" - , fromString $ T.unpack t <> "." - ] - pretty (PackageVersionParseFail t) = - "[S-479]" - <> line - <> fillSep - [ flow "Invalid version:" - , fromString $ T.unpack t <> "." - ] - pretty (InvalidCabalFilePath fp) = - "[S-824]" - <> line - <> fillSep - [ flow "File path contains a name which is not a valid package name:" - , pretty fp <> "." - ] - pretty (DuplicatePackageNames source pairs') = - "[S-674]" - <> line - <> fillSep - [ flow "Duplicate package names" - , parens (fromString . T.unpack $ textDisplay source) <> ":" - ] - <> line - <> foldMap - ( \(name, locs) -> - fromString (packageNameString name) <> ":" - <> line - <> bulletedList (map pretty locs) - <> line - ) - pairs' - pretty (MigrationFailure desc fp err) = - "[S-536]" - <> line - <> fillSep - [ flow "Encountered error while migrating database" - , fromString $ T.unpack desc - , flow "located at" - , pretty fp <> ":" - ] - <> blankLine - <> string (displayException err) - pretty (ParseSnapNameException t) = - "[S-994]" - <> line - <> fillSep - [ flow "Invalid snapshot name:" - , fromString $ T.unpack t <> "." - ] - pretty (HpackLibraryException file err) = - "[S-305]" - <> line - <> fillSep - [ flow "Failed to generate a Cabal file using the Hpack library on" - , "file:" - , pretty file <> "." - , flow "The error encountered was:" - ] - <> blankLine - <> string err - pretty (HpackExeException fp dir err) = - "[S-720]" - <> line - <> fillSep - [ flow "Failed to generate a Cabal file using the Hpack executable:" - , style File (fromString fp) - , flow "in directory:" - , pretty dir <> "." - , flow "The error encountered was:" - ] - <> blankLine - <> string (displayException err) - -blankLine :: StyleDoc -blankLine = line <> line - -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) <> - "." - -prettyFuzzy :: FuzzyResults -> StyleDoc -prettyFuzzy (FRNameNotFound names) = - case NE.nonEmpty names of - Nothing -> mempty - Just names' -> - line - <> fillSep - ( flow "Perhaps you meant one of" - : mkNarrativeList Nothing False - (NE.toList $ NE.map (fromString . packageNameString) names' :: [StyleDoc]) - ) -prettyFuzzy (FRVersionNotFound pirs) = - line - <> fillSep - ( flow "Possible candidates:" - : mkNarrativeList Nothing False - (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc]) - ) -prettyFuzzy (FRRevisionNotFound pirs) = - line - <> fillSep - ( flow "The specified revision was not found. Possible candidates:" - : mkNarrativeList Nothing False - (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc]) - ) - -orSeparated :: NonEmpty Utf8Builder -> Utf8Builder -orSeparated xs - | NE.length xs == 1 = NE.head xs - | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs - | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs - -commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder -commaSeparated = fold . NE.intersperse ", " - -cabalSpecLatestVersion :: Version -cabalSpecLatestVersion = mkVersion $ cabalSpecToVersionDigits cabalSpecLatest - -#if !MIN_VERSION_Cabal(3,4,0) -cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] -cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] -cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] -cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] -cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] -cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] -cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] -cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] -cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] -cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] -cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] -cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] -cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] -cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] -cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] -cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] -#endif - -data BuildFile - = BFCabal !SafeFilePath !TreeEntry - | BFHpack !TreeEntry - -- We don't need SafeFilePath for Hpack since it has to be package.yaml file - deriving (Show, Eq) - -data FileType = FTNormal | FTExecutable - deriving (Show, Eq, Enum, Bounded, Ord) - -instance PersistField FileType where - toPersistValue FTNormal = PersistInt64 1 - toPersistValue FTExecutable = PersistInt64 2 - - fromPersistValue v = do - i <- fromPersistValue v - case i :: Int64 of - 1 -> Right FTNormal - 2 -> Right FTExecutable - _ -> Left $ "Invalid FileType: " <> tshow i - -instance PersistFieldSql FileType where - sqlType _ = SqlInt32 - -data TreeEntry = TreeEntry - { teBlob :: !BlobKey - , teType :: !FileType - } - deriving (Show, Eq, Ord) - -newtype SafeFilePath = SafeFilePath Text - deriving (Show, Eq, Ord, Display) - -instance PersistField SafeFilePath where - toPersistValue = toPersistValue . unSafeFilePath - fromPersistValue v = do - t <- fromPersistValue v - maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t - -instance PersistFieldSql SafeFilePath where - sqlType _ = SqlString - -unSafeFilePath :: SafeFilePath -> Text -unSafeFilePath (SafeFilePath t) = t - -safeFilePathToPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File) -safeFilePathToPath dir (SafeFilePath path) = do - fpath <- parseRelFile (T.unpack path) - pure $ 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 $ (not . any (T.all (== '.'))) $ T.split (== '/') t - - Just $ SafeFilePath t - --- | SafeFilePath for `package.yaml` file. -hpackSafeFilePath :: SafeFilePath -hpackSafeFilePath = - let fpath = mkSafeFilePath (T.pack Hpack.packageConfig) - in case fpath of - Nothing -> error $ - "hpackSafeFilePath: Not able to encode " <> Hpack.packageConfig - Just sfp -> sfp - --- | The hash of the binary representation of a 'Tree'. --- --- @since 0.1.0.0 -newtype TreeKey = TreeKey BlobKey - deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display) - --- | Represents the contents of a tree, which is a mapping from --- relative file paths to 'TreeEntry's. --- --- @since 0.1.0.0 -newtype Tree - = TreeMap (Map SafeFilePath TreeEntry) - -- In the future, consider allowing more lax parsing - -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys - -- TreeTarball !PackageTarball - deriving (Show, Eq, Ord) - -renderTree :: Tree -> ByteString -renderTree = BL.toStrict . toLazyByteString . go - where - go :: Tree -> Builder - go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m - - goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = - netstring (unSafeFilePath sfp) <> - byteString (SHA256.toRaw sha) <> - netword size' <> - (case ft of - FTNormal -> "N" - FTExecutable -> "X") - -netstring :: Text -> Builder -netstring t = - let bs = encodeUtf8 t - in netword (fromIntegral (B.length bs)) <> byteString bs - -netword :: Word -> Builder -netword w = wordDec w <> ":" - -parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree) -parseTreeM (blobKey, blob) = - case parseTree blob of - Nothing -> throwM (InvalidTreeFromCasa blobKey blob) - Just tree -> pure (TreeKey blobKey, tree) - -parseTree :: ByteString -> Maybe Tree -parseTree bs1 = do - tree <- parseTree' bs1 - let bs2 = renderTree tree - guard $ bs1 == bs2 - Just tree - -parseTree' :: ByteString -> Maybe Tree -parseTree' bs0 = do - entriesBS <- B.stripPrefix "map:" bs0 - TreeMap <$> loop Map.empty entriesBS - where - loop !m bs1 - | B.null bs1 = pure m - | otherwise = do - (sfpBS, bs2) <- takeNetstring bs1 - sfp <- - case decodeUtf8' sfpBS of - Left _ -> Nothing - Right sfpT -> mkSafeFilePath sfpT - (sha, bs3) <- takeSha bs2 - (size', bs4) <- takeNetword bs3 - (typeW, bs5) <- B.uncons bs4 - ft <- - case typeW of - 78 -> Just FTNormal -- 'N' - 88 -> Just FTExecutable -- 'X' - _ -> Nothing - let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft - loop (Map.insert sfp entry m) bs5 - - takeNetstring bs1 = do - (size', bs2) <- takeNetword bs1 - guard $ B.length bs2 >= size' - Just $ B.splitAt size' bs2 - - takeSha bs = do - let (x, y) = B.splitAt 32 bs - x' <- either (const Nothing) Just (SHA256.fromRaw x) - Just (x', y) - - takeNetword = - go 0 - where - go !accum bs = do - (next, rest) <- B.uncons bs - if - | next == 58 -> pure (accum, rest) -- ':' - | next >= 48 && next <= 57 -> - go - (accum * 10 + fromIntegral (next - 48)) - rest - | otherwise -> Nothing - - {- -data PackageTarball = PackageTarball - { ptBlob :: !BlobKey - -- ^ Contains the tarball itself - , ptCabal :: !BlobKey - -- ^ Contains the cabal file contents - , ptSubdir :: !FilePath - -- ^ Subdir containing the files we want for this package. - -- - -- There must be precisely one file with a @.cabal@ file extension - -- located there. Thanks to Hackage revisions, its contents will be - -- overwritten by the value of @ptCabal@. - } - deriving Show - -} - --- | This is almost a copy of Cabal's parser for package identifiers, --- the main difference is in the fact that Stack requires version to be --- present while Cabal uses "null version" as a default value --- --- @since 0.1.0.0 -parsePackageIdentifier :: String -> Maybe PackageIdentifier -parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof) - -packageIdentifierParsec :: ParsecParser PackageIdentifier -packageIdentifierParsec = do - ident@(PackageIdentifier _ v) <- parsec - - -- version is a required component of a package identifier for Stack - guard (v /= nullVersion) - - pure ident - --- | Parse a package name from a 'String'. --- --- @since 0.1.0.0 -parsePackageName :: String -> Maybe PackageName -parsePackageName = Distribution.Text.simpleParse - --- | Parse a package name from a 'String' throwing on failure --- --- @since 0.1.0.0 -parsePackageNameThrowing :: MonadThrow m => String -> m PackageName -parsePackageNameThrowing str = - case parsePackageName str of - Nothing -> throwM $ PackageNameParseFail $ T.pack str - Just pn -> pure pn - --- | Parse a version from a 'String'. --- --- @since 0.1.0.0 -parseVersion :: String -> Maybe Version -parseVersion = Distribution.Text.simpleParse - --- | Parse a package version from a 'String' throwing on failure --- --- @since 0.1.0.0 -parseVersionThrowing :: MonadThrow m => String -> m Version -parseVersionThrowing str = - case parseVersion str of - Nothing -> throwM $ PackageVersionParseFail $ T.pack str - Just v -> pure v - --- | Parse a version range from a 'String'. --- --- @since 0.1.0.0 -parseVersionRange :: String -> Maybe VersionRange -parseVersionRange = Distribution.Text.simpleParse - --- | Parse a module name from a 'String'. --- --- @since 0.1.0.0 -parseModuleName :: String -> Maybe ModuleName -parseModuleName = Distribution.Text.simpleParse - --- | Parse a flag name from a 'String'. --- --- @since 0.1.0.0 -parseFlagName :: String -> Maybe FlagName -parseFlagName = Distribution.Text.simpleParse - --- | Render a package name as a 'String'. --- --- @since 0.1.0.0 -packageNameString :: PackageName -> String -packageNameString = unPackageName - --- | Render a package identifier as a 'String'. --- --- @since 0.1.0.0 -packageIdentifierString :: PackageIdentifier -> String -packageIdentifierString = Distribution.Text.display - --- | Render a version as a 'String'. --- --- @since 0.1.0.0 -versionString :: Version -> String -versionString = Distribution.Text.display - --- | Render a flag name as a 'String'. --- --- @since 0.1.0.0 -flagNameString :: FlagName -> String -flagNameString = unFlagName - --- | Render a module name as a 'String'. --- --- @since 0.1.0.0 -moduleNameString :: ModuleName -> String -moduleNameString = Distribution.Text.display - -data OptionalSubdirs - = OSSubdirs !(NonEmpty Text) - | OSPackageMetadata !Text !RawPackageMetadata - -- ^ subdirectory and package metadata - deriving (Show, Eq, Generic) - -instance NFData OptionalSubdirs - --- | Metadata provided by a config file for archives and repos. This information --- can be used for optimized lookups of information like package identifiers, or --- for validating that the user configuration has the expected information. --- --- @since 0.1.0.0 -data RawPackageMetadata = RawPackageMetadata - { rpmName :: !(Maybe PackageName) - -- ^ Package name in the cabal file - -- - -- @since 0.1.0.0 - , rpmVersion :: !(Maybe Version) - -- ^ Package version in the cabal file - -- - -- @since 0.1.0.0 - , rpmTreeKey :: !(Maybe TreeKey) - -- ^ Tree key of the loaded up package - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Ord, Generic, Typeable) - -instance NFData RawPackageMetadata - -instance Display RawPackageMetadata where - display rpm = fold $ intersperse ", " $ catMaybes - [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm - , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm - , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm - ] - --- | Exact metadata specifying concrete package --- --- @since 0.1.0.0 -data PackageMetadata = PackageMetadata - { pmIdent :: !PackageIdentifier - -- ^ Package identifier in the cabal file - -- - -- @since 0.1.0.0 - , pmTreeKey :: !TreeKey - -- ^ Tree key of the loaded up package - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Ord, Generic, Typeable) - --- i PackageMetadata -instance NFData PackageMetadata - -instance Display PackageMetadata where - display pm = fold $ intersperse ", " - [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm) - , "tree == " <> display (pmTreeKey pm) - ] - -parsePackageMetadata :: Object -> WarningParser PackageMetadata -parsePackageMetadata o = do - _oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file" - pantryTree :: BlobKey <- o ..: "pantry-tree" - CabalString pkgName <- o ..: "name" - CabalString pkgVersion <- o ..: "version" - let pmTreeKey = TreeKey pantryTree - pmIdent = PackageIdentifier {..} - pure PackageMetadata {..} - - --- | Convert package metadata to its "raw" equivalent. --- --- @since 0.1.0.0 -toRawPM :: PackageMetadata -> RawPackageMetadata -toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) - where - PackageIdentifier name version = pmIdent pm - --- | File path relative to the configuration file it was parsed from --- --- @since 0.1.0.0 -newtype RelFilePath = RelFilePath Text - deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display) - --- | Location that an archive is stored at --- --- @since 0.1.0.0 -data ArchiveLocation - = ALUrl !Text - -- ^ Archive stored at an HTTP(S) URL - -- - -- @since 0.1.0.0 - | ALFilePath !(ResolvedPath File) - -- ^ Archive stored at a local file path - -- - -- @since 0.1.0.0 - deriving (Show, Eq, Ord, Generic, Typeable) - -instance NFData ArchiveLocation - -instance Display ArchiveLocation where - display (ALUrl url) = display url - display (ALFilePath resolved) = - fromString $ toFilePath $ resolvedAbsolute resolved - -instance Pretty ArchiveLocation where - pretty (ALUrl url) = style Url (fromString $ T.unpack url) - pretty (ALFilePath resolved) = pretty $ resolvedAbsolute resolved - -parseArchiveLocationObject :: - Object - -> WarningParser (Unresolved ArchiveLocation) -parseArchiveLocationObject o = - ((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl) - <|> ((o ..: "filepath") >>= either (fail . T.unpack) pure . validateFilePath) - <|> ((o ..: "archive") >>= either (fail . T.unpack) pure . parseArchiveLocationText) - <|> ((o ..: "location") >>= either (fail . T.unpack) pure . parseArchiveLocationText) - -parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation) -parseArchiveLocationText t = - case validateUrl t of - Left e1 -> - case validateFilePath t of - Left e2 -> Left $ T.unlines - [ "Invalid archive location, neither a URL nor a file path" - , " URL error: " <> e1 - , " File path error: " <> e2 - ] - Right x -> Right x - Right x -> Right x - -validateUrl :: Text -> Either Text (Unresolved ArchiveLocation) -validateUrl t = - case parseRequest $ T.unpack t of - Left _ -> Left $ "Could not parse URL: " <> t - Right _ -> pure $ pure $ ALUrl t - -validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation) -validateFilePath t = - if any (`T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") - then pure $ Unresolved $ \case - Nothing -> throwIO $ InvalidFilePathSnapshot t - Just dir -> do - abs' <- resolveFile dir $ T.unpack t - pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' - else Left $ "Does not have an archive file extension: " <> t - -instance ToJSON RawPackageLocation where - toJSON (RPLImmutable rpli) = toJSON rpli - toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved) - -instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where - parseJSON v = - (fmap . fmap . fmap . fmap) RPLImmutable (parseJSON v) <|> - (noJSONWarnings . mkMutable <$> parseJSON v) - where - mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation) - mkMutable t = Unresolved $ \mdir -> do - case mdir of - Nothing -> throwIO $ MutablePackageLocationFromUrl t - Just dir -> do - abs' <- resolveDir dir $ T.unpack t - pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs' - -instance ToJSON RawPackageLocationImmutable where - toJSON (RPLIHackage pir mtree) = object $ - ("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 - , [ "subdir" .= subdir | not (T.null subdir) ] - , rpmToPairs rpm - ] - toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat - [ [ urlKey .= url - , "commit" .= commit - ] - , ["subdir" .= subdir | not (T.null subdir) ] - , rpmToPairs rpm - ] - where - urlKey = - case typ of - RepoGit -> "git" - RepoHg -> "hg" - -rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)] -rpmToPairs (RawPackageMetadata mname mversion mtree) = concat - [ maybe [] (\name -> ["name" .= CabalString name]) mname - , maybe [] (\version -> ["version" .= CabalString version]) mversion - , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree - ] - -instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where - parseJSON v = - repoObject v - <|> archiveObject v - <|> hackageObject v - <|> github v - <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) - where - repoObject :: - Value - -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) - repoObject = - withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do - pm <- parsePackageMetadata o - repoSubdir <- o ..:? "subdir" ..!= "" - repoCommit <- o ..: "commit" - (repoType, repoUrl) <- - (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> - (o ..: "hg" >>= \url -> pure (RepoHg, url)) - pure $ pure $ PLIRepo Repo {..} pm - - archiveObject = - withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do - pm <- parsePackageMetadata o - Unresolved mkArchiveLocation <- parseArchiveLocationObject o - archiveHash <- o ..: "sha256" - archiveSize <- o ..: "size" - archiveSubdir <- o ..:? "subdir" ..!= "" - pure $ Unresolved $ \mdir -> do - archiveLocation <- mkArchiveLocation mdir - pure $ PLIArchive Archive {..} pm - - hackageObject = - withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do - treeKey <- o ..: "pantry-tree" - htxt <- o ..: "hackage" - case parseHackageText htxt of - Left e -> fail $ show e - Right (pkgIdentifier, blobKey) -> - pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) - - github = - 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) - -instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where - parseJSON v = - http v - <|> hackageText v - <|> hackageObject v - <|> repo v - <|> archiveObject v - <|> github v - <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) - where - http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) - http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> - case parseArchiveLocationText t of - Left _ -> fail $ "Invalid archive location: " ++ T.unpack t - Right (Unresolved mkArchiveLocation) -> - pure $ noJSONWarnings $ Unresolved $ \mdir -> do - raLocation <- mkArchiveLocation mdir - let raHash = Nothing - raSize = Nothing - raSubdir = T.empty - pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty - - hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> - case parsePackageIdentifierRevision t of - Left e -> fail $ show e - Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing - - hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> pure . pure <$> (RPLIHackage - <$> o ..: "hackage" - <*> o ..:? "pantry-tree") - - optionalSubdirs :: Object -> WarningParser OptionalSubdirs - optionalSubdirs o = - -- if subdirs exists, it needs to be valid - case HM.lookup "subdirs" o of - Just v' -> do - tellJSONField "subdirs" - subdirs <- lift $ parseJSON v' - case NE.nonEmpty subdirs of - Nothing -> fail "Invalid empty subdirs" - Just x -> pure $ OSSubdirs x - Nothing -> OSPackageMetadata - <$> o ..:? "subdir" ..!= T.empty - <*> ( rawPackageMetadataHelper - <$> (fmap unCabalString <$> (o ..:? "name")) - <*> (fmap unCabalString <$> (o ..:? "version")) - <*> o ..:? "pantry-tree" - <*> o ..:? "cabal-file" - ) - - rawPackageMetadataHelper :: - Maybe PackageName - -> Maybe Version - -> Maybe TreeKey - -> Maybe BlobKey - -> RawPackageMetadata - rawPackageMetadataHelper name version pantryTree _ignoredCabalFile = - RawPackageMetadata name version pantryTree - - repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do - (repoType, repoUrl) <- - ((RepoGit, ) <$> o ..: "git") <|> - ((RepoHg, ) <$> o ..: "hg") - repoCommit <- o ..: "commit" - os <- optionalSubdirs o - pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) - - archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do - Unresolved mkArchiveLocation <- parseArchiveLocationObject o - raHash <- o ..:? "sha256" - raSize <- o ..:? "size" - os <- optionalSubdirs o - pure $ Unresolved $ \mdir -> do - raLocation <- mkArchiveLocation mdir - pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) - - github = withObjectWarnings "PLArchive:github" $ \o -> do - GitHubRepo ghRepo <- o ..: "github" - commit <- o ..: "commit" - let raLocation = ALUrl $ T.concat - [ "https://github.com/" - , ghRepo - , "/archive/" - , commit - , ".tar.gz" - ] - raHash <- o ..:? "sha256" - raSize <- o ..:? "size" - os <- optionalSubdirs o - pure $ pure $ - NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) - --- | Returns pairs of subdirectory and 'PackageMetadata'. -osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata) -osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs -osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm) - -rpmEmpty :: RawPackageMetadata -rpmEmpty = RawPackageMetadata Nothing Nothing Nothing - --- | Newtype wrapper for easier JSON integration with Cabal types. --- --- @since 0.1.0.0 -newtype CabalString a = CabalString { unCabalString :: a } - deriving (Show, Eq, Ord, Typeable) - --- I'd like to use coerce here, but can't due to roles. unsafeCoerce --- could work, but let's avoid unsafe code. - --- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON' --- instance. --- --- @since 0.1.0.0 -toCabalStringMap :: Map a v -> Map (CabalString a) v -toCabalStringMap = Map.mapKeysMonotonic CabalString - --- | Unwrap the 'CabalString' from the keys in a 'Map' to use a --- 'FromJSON' instance. --- --- @since 0.1.0.0 -unCabalStringMap :: Map (CabalString a) v -> Map a v -unCabalStringMap = Map.mapKeysMonotonic unCabalString - -instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where - toJSON = toJSON . Distribution.Text.display . unCabalString - -instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where - toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString - -instance forall a. IsCabalString a => FromJSON (CabalString a) where - parseJSON = withText name $ \t -> - case cabalStringParser $ T.unpack t of - Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t - Just x -> pure $ CabalString x - where - name = cabalStringName (Nothing :: Maybe a) - -instance forall a. IsCabalString a => FromJSONKey (CabalString a) where - fromJSONKey = - FromJSONKeyTextParser $ \t -> - case cabalStringParser $ T.unpack t of - Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t - Just x -> pure $ CabalString x - where - name = cabalStringName (Nothing :: Maybe a) - -class IsCabalString a where - cabalStringName :: proxy a -> String - cabalStringParser :: String -> Maybe a - -instance IsCabalString PackageName where - cabalStringName _ = "package name" - cabalStringParser = parsePackageName - -instance IsCabalString Version where - cabalStringName _ = "version" - cabalStringParser = parseVersion - -instance IsCabalString VersionRange where - cabalStringName _ = "version range" - cabalStringParser = parseVersionRange - -instance IsCabalString PackageIdentifier where - cabalStringName _ = "package identifier" - cabalStringParser = parsePackageIdentifier - -instance IsCabalString FlagName where - cabalStringName _ = "flag name" - cabalStringParser = parseFlagName - --- | What to use for running hpack --- --- @since 0.1.0.0 -data HpackExecutable - = HpackBundled - -- ^ Compiled in library - | HpackCommand !FilePath - -- ^ Executable at the provided path - deriving (Show, Read, Eq, Ord) - - --- | Which compiler a snapshot wants to use. The build tool may elect to do some --- fuzzy matching of versions (e.g., allowing different patch versions). --- --- @since 0.1.0.0 -data WantedCompiler - = WCGhc !Version - | WCGhcGit !Text !Text - | WCGhcjs - !Version - !Version - -- ^ GHCJS version followed by GHC version - deriving (Show, Eq, Ord, Generic) - -instance NFData WantedCompiler - -instance Display WantedCompiler where - display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) - display (WCGhcjs vghcjs vghc) = - "ghcjs-" - <> fromString (versionString vghcjs) - <> "_ghc-" <> fromString (versionString vghc) - display (WCGhcGit commit flavour) = - "ghc-git-" <> display commit <> "-" <> display flavour - -instance ToJSON WantedCompiler where - toJSON = toJSON . utf8BuilderToText . display - -instance FromJSON WantedCompiler where - parseJSON = - withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler - -instance FromJSONKey WantedCompiler where - fromJSONKey = - FromJSONKeyTextParser $ \t -> - case parseWantedCompiler t of - Left e -> fail $ "Invalid WantedCompiler " ++ show t ++ ": " ++ show e - Right x -> pure x - --- | Parse a 'Text' into a 'WantedCompiler' value. --- --- @since 0.1.0.0 -parseWantedCompiler :: Text -> Either PantryException WantedCompiler -parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ - case T.stripPrefix "ghcjs-" t0 of - Just t1 -> parseGhcjs t1 - Nothing -> case T.stripPrefix "ghc-git-" t0 of - Just t1 -> parseGhcGit t1 - Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc - where - parseGhcjs t1 = do - let (ghcjsVT, t2) = T.break (== '_') t1 - ghcjsV <- parseVersion $ T.unpack ghcjsVT - ghcVT <- T.stripPrefix "_ghc-" t2 - ghcV <- parseVersion $ T.unpack ghcVT - pure $ WCGhcjs ghcjsV ghcV - parseGhcGit t1 = do - let (commit, flavour) = T.break (== '-') t1 - pure $ WCGhcGit commit (T.drop 1 flavour) - parseGhc = fmap WCGhc . parseVersion . T.unpack - -instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where - parseJSON v = text v <|> obj v - where - text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) - text = - withText "UnresolvedSnapshotLocation (Text)" $ - pure . noJSONWarnings . parseRawSnapshotLocation - - obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) - obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> - (pure . RSLCompiler <$> o ..: "compiler") <|> - ((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|> - (parseRawSnapshotLocationPath <$> o ..: "filepath") - - blobKey o = do - msha <- o ..:? "sha256" - msize <- o ..:? "size" - case (msha, msize) of - (Nothing, Nothing) -> pure Nothing - (Just sha, Just size') -> pure $ Just $ BlobKey sha size' - (Just _sha, Nothing) -> fail "You must also specify the file size" - (Nothing, Just _) -> fail "You must also specify the file's SHA256" - -instance Display SnapshotLocation where - display (SLCompiler compiler) = display compiler - display (SLUrl url blob) = display url <> " (" <> display blob <> ")" - display (SLFilePath resolved) = display (resolvedRelative resolved) - --- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. --- --- @since 0.1.0.0 -parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation -parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $ - either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0) <|> - (pure . RSLSynonym <$> parseSnapName t0) <|> - parseGitHub <|> - parseUrl - where - parseGitHub = do - t1 <- T.stripPrefix "github:" t0 - let (user, t2) = T.break (== '/') t1 - t3 <- T.stripPrefix "/" t2 - let (repo, t4) = T.break (== ':') t3 - path <- T.stripPrefix ":" t4 - Just $ pure $ githubSnapshotLocation user repo path - - parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) - -parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation -parseRawSnapshotLocationPath t = - Unresolved $ \case - Nothing -> throwIO $ InvalidFilePathSnapshot t - Just dir -> do - abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) - pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' - -githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation -githubSnapshotLocation user repo path = - let url = T.concat - [ "https://raw.githubusercontent.com/" - , user - , "/" - , repo - , "/master/" - , path - ] - in RSLUrl url Nothing - -defUser :: Text -defUser = "commercialhaskell" - -defRepo :: Text -defRepo = "stackage-snapshots" - --- | Default location of snapshot synonyms, i.e. commercialhaskell's GitHub --- repository. --- --- @since 0.5.0.0 -defaultSnapshotLocation :: - SnapName - -> RawSnapshotLocation -defaultSnapshotLocation (LTS x y) = - githubSnapshotLocation defUser defRepo $ - utf8BuilderToText $ - "lts/" <> display x <> "/" <> display y <> ".yaml" -defaultSnapshotLocation (Nightly date) = - githubSnapshotLocation defUser defRepo - $ utf8BuilderToText - $ "nightly/" - <> display year - <> "/" - <> display month - <> "/" - <> display day - <> ".yaml" - where - (year, month, day) = toGregorian date - --- | A snapshot synonym. It is expanded according to the field --- 'snapshotLocation' of a 'PantryConfig'. --- --- @ since 0.5.0.0 -data SnapName - = LTS - !Int -- ^ Major version - !Int -- ^ Minor version - -- ^ LTS Haskell snapshot, displayed as @"lts-maj.min"@. - -- - -- @since 0.5.0.0 - | Nightly !Day - -- ^ Stackage Nightly snapshot, displayed as @"nighly-YYYY-MM-DD"@. - -- - -- @since 0.5.0.0 - deriving (Eq, Ord, Generic) - -instance NFData SnapName - -instance Display SnapName where - display (LTS x y) = "lts-" <> display x <> "." <> display y - display (Nightly date) = "nightly-" <> displayShow date - -instance Show SnapName where - show = T.unpack . utf8BuilderToText . display - -instance ToJSON SnapName where - toJSON syn = String $ utf8BuilderToText $ display syn - --- | Parse the short representation of a 'SnapName'. --- --- @since 0.5.0.0 -parseSnapName :: MonadThrow m => Text -> m SnapName -parseSnapName t0 = - case lts <|> nightly of - Nothing -> throwM $ ParseSnapNameException t0 - Just sn -> pure sn - where - lts = do - t1 <- T.stripPrefix "lts-" t0 - Right (x, t2) <- Just $ decimal t1 - t3 <- T.stripPrefix "." t2 - Right (y, "") <- Just $ decimal t3 - pure $ LTS x y - nightly = do - t1 <- T.stripPrefix "nightly-" t0 - Nightly <$> readMaybe (T.unpack t1) - --- | Where to load a snapshot from in raw form (RSUrl could have a missing --- BlobKey) --- --- @since 0.1.0.0 -data RawSnapshotLocation - = RSLCompiler !WantedCompiler - -- ^ Don't use an actual snapshot, just a version of the compiler with its - -- shipped packages. - -- - -- @since 0.1.0.0 - | RSLUrl !Text !(Maybe BlobKey) - -- ^ Download the snapshot from the given URL. The optional 'BlobKey' is - -- used for reproducibility. - -- - -- @since 0.1.0.0 - | RSLFilePath !(ResolvedPath File) - -- ^ Snapshot at a local file path. - -- - -- @since 0.1.0.0 - | RSLSynonym !SnapName - -- ^ Snapshot synonym (LTS/Nightly). - -- - -- @since 0.5.0.0 - deriving (Show, Eq, Ord, Generic) - -instance NFData RawSnapshotLocation - -instance Display RawSnapshotLocation where - display (RSLCompiler compiler) = display compiler - display (RSLUrl url Nothing) = display url - display (RSLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" - display (RSLFilePath resolved) = display (resolvedRelative resolved) - display (RSLSynonym syn) = display syn - -instance Pretty RawSnapshotLocation where - pretty (RSLCompiler compiler) = fromString . T.unpack $ textDisplay compiler - pretty (RSLUrl url Nothing) = style Url (fromString $ T.unpack url) - pretty (RSLUrl url (Just blob)) = fillSep - [ style Url (fromString $ T.unpack url) - , parens (fromString . T.unpack $ textDisplay blob) - ] - pretty (RSLFilePath resolved) = - style File (fromString . T.unpack $ textDisplay (resolvedRelative resolved)) - pretty (RSLSynonym syn) = - style Shell (fromString . T.unpack $ textDisplay syn) - -instance ToJSON RawSnapshotLocation where - toJSON (RSLCompiler compiler) = object ["compiler" .= compiler] - toJSON (RSLUrl url mblob) = object - $ "url" .= url - : maybe [] blobKeyPairs mblob - toJSON (RSLFilePath resolved) = - object ["filepath" .= resolvedRelative resolved] - toJSON (RSLSynonym syn) = toJSON syn - --- | Where to load a snapshot from. --- --- @since 0.1.0.0 -data SnapshotLocation - = SLCompiler !WantedCompiler - -- ^ Don't use an actual snapshot, just a version of the compiler - -- with its shipped packages. - -- - -- @since 0.1.0.0 - | SLUrl !Text !BlobKey - -- ^ Download the snapshot from the given URL. The optional - -- 'BlobKey' is used for reproducibility. - -- - -- @since 0.1.0.0 - | SLFilePath !(ResolvedPath File) - -- ^ Snapshot at a local file path. - -- - -- @since 0.1.0.0 - deriving (Show, Eq, Ord, Generic) - -instance NFData SnapshotLocation - -instance ToJSON SnapshotLocation where - toJSON sl = toJSON (toRawSL sl) - -instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where - parseJSON v = file v <|> url v <|> compiler v - where - file = withObjectWarnings "SLFilepath" $ \o -> do - ufp <- o ..: "filepath" - pure $ Unresolved $ \case - 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] - , [ "drop-packages" .= Set.map CabalString (rslDropPackages rsnap) - | not (Set.null (rslDropPackages rsnap)) - ] - , [ "flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap)) - | not(Map.null (rslFlags rsnap)) - ] - , [ "hidden" .= toCabalStringMap (rslHidden rsnap) - | not (Map.null (rslHidden rsnap)) - ] - , [ "ghc-options" .= toCabalStringMap (rslGhcOptions rsnap) - | not (Map.null (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 {..}) - <$> (concatMap 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] - , [ "drop-packages" .= Set.map CabalString (slDropPackages snap) - | not (Set.null (slDropPackages snap)) - ] - , [ "flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap)) - | not (Map.null (slFlags snap)) - ] - , [ "hidden" .= toCabalStringMap (slHidden snap) - | not (Map.null (slHidden snap)) - ] - , [ "ghc-options" .= toCabalStringMap (slGhcOptions snap) - | not (Map.null (slGhcOptions snap)) - ] - , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap) - ] - --- | Convert snapshot layer into its "raw" equivalent. --- --- @since 0.1.0.0 -toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer -toRawSnapshotLayer sl = RawSnapshotLayer - { rslParent = toRawSL (slParent sl) - , rslCompiler = slCompiler sl - , rslLocations = map toRawPLI (slLocations sl) - , rslDropPackages = slDropPackages sl - , rslFlags = slFlags sl - , rslHidden = slHidden sl - , rslGhcOptions = slGhcOptions sl - , rslPublishTime = slPublishTime sl - } - --- | An arbitrary hash for a snapshot, used for finding module names in a --- snapshot. Mostly intended for Stack's usage. --- --- @since 0.1.0.0 -newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} - deriving (Show) - --- | Get the path to the global hints cache file -getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File) -getGlobalHintsFile = do - root <- view $ pantryConfigL.to pcRootDir - globalHintsRelFile <- parseRelFile "global-hints-cache.yaml" - pure $ root globalHintsRelFile - --- | Creates BlobKey for an input ByteString --- --- @since 0.1.0.0 -bsToBlobKey :: ByteString -> BlobKey -bsToBlobKey bs = - BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) - --- | Warn if the package uses 'PCHpack'. --- --- @since 0.4.0.0 -warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env () -warnMissingCabalFile loc = - logWarn $ - "DEPRECATED: The package at " - <> display loc - <> " does not include a cabal file.\n" - <> "Instead, it includes an hpack package.yaml file for generating a cabal file.\n" - <> "This usage is deprecated; please see " - <> "https://github.com/commercialhaskell/stack/issues/5210.\n" - <> "Support for this workflow will be removed in the future.\n" diff --git a/test/Pantry/BuildPlanSpec.hs b/test/Pantry/BuildPlanSpec.hs --- a/test/Pantry/BuildPlanSpec.hs +++ b/test/Pantry/BuildPlanSpec.hs @@ -4,11 +4,11 @@ module Pantry.BuildPlanSpec where import Control.Monad.Catch ( MonadThrow ) +import Data.Aeson.WarningParser ( WithJSONWarnings(..) ) import qualified Data.ByteString.Char8 as S8 import Data.List.NonEmpty ( NonEmpty ) import Data.Yaml ( decodeThrow ) import Pantry -import Pantry.Internal.AesonExtended ( WithJSONWarnings(..) ) import RIO import Test.Hspec diff --git a/test/Pantry/GlobalHintsSpec.hs b/test/Pantry/GlobalHintsSpec.hs --- a/test/Pantry/GlobalHintsSpec.hs +++ b/test/Pantry/GlobalHintsSpec.hs @@ -9,7 +9,7 @@ import Distribution.Types.PackageName ( mkPackageName ) import Distribution.Version ( mkVersion ) import Pantry ( WantedCompiler (..), loadGlobalHints, runPantryAppClean ) -import Pantry.Internal +import Pantry.Types ( getGlobalHintsFile ) import Path ( toFilePath ) import RIO import qualified RIO.Map as Map diff --git a/test/Pantry/Internal/StaticBytesSpec.hs b/test/Pantry/Internal/StaticBytesSpec.hs deleted file mode 100644 --- a/test/Pantry/Internal/StaticBytesSpec.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Pantry.Internal.StaticBytesSpec - ( spec - ) where - -import Control.Monad ( replicateM ) -import qualified Data.ByteString as B -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Vector.Primitive as VP -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Unboxed as VU -import Pantry.Internal.StaticBytes -import RIO -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck - -spec :: Spec -spec = do - describe "ByteString" $ tests B.pack - describe "Storable Vector" $ tests VS.fromList - describe "Unboxed Vector" $ tests VU.fromList - describe "Primitive Vector" $ tests VP.fromList - -tests :: (Eq dbytes, Show dbytes, DynamicBytes dbytes) => ([Word8] -> dbytes) -> Spec -tests pack = do - it "disallows 4 bytes" $ property $ \(w1,w2,w3,w4) -> - toStaticExact (pack [w1,w2,w3,w4]) `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes8) - it "toStaticExact matches ByteString" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do - let octets = [w1,w2,w3,w4,w5,w6,w7,w8] - (expected :: Bytes8) = either impureThrow id $ toStaticExact (B.pack octets) - actual = either impureThrow id $ toStaticExact (pack octets) - actual `shouldBe` expected - - it "fromStatic round trips" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do - let octets = [w1,w2,w3,w4,w5,w6,w7,w8] - v1 = pack octets - (b8 :: Bytes8) = either impureThrow id $ toStaticExact v1 - v2 = fromStatic b8 - v2 `shouldBe` v1 - - it "allows 8 bytes" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do - let bs = pack [w1,w2,w3,w4,w5,w6,w7,w8] - case toStaticExact bs of - Left e -> throwIO e - Right b8 -> fromStatic (b8 :: Bytes8) `shouldBe` bs - toStaticExact bs `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes16) - it "padding is the same as trailing nulls" $ property $ \(w1,w2,w3,w4) -> do - let ws = [w1,w2,w3,w4] - bs1 = pack $ ws ++ replicate 4 0 - bs2 = pack ws - Right (toStaticPadTruncate bs2 :: Bytes8) `shouldBe` toStaticExact bs1 - - prop "handles bytes16" $ \octets -> do - let bs = pack $ take 16 octets - (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs - fromStatic b16 `shouldBe` pack (take 16 (octets ++ replicate 16 0)) - - it "spot check bytes16" $ forAll (replicateM 16 arbitrary) $ \ws -> do - let bs = pack ws - (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs - fromStatic b16 `shouldBe` pack ws - - prop "handles bytes32" $ \octets -> do - let bs = pack $ take 32 octets - (b32 :: Bytes32) = either impureThrow id $ toStaticPad bs - fromStatic b32 `shouldBe` pack (take 32 (take 32 octets ++ replicate 32 0)) - - prop "fuzz with encodeUtf8" $ \chars -> do - let t = T.pack $ filter (/= '\0') chars - bs = TE.encodeUtf8 t - bs128 = pack $ B.unpack $ B.take 128 $ bs `B.append` B.replicate 128 0 - b128 = toStaticPadTruncate (pack $ B.unpack bs) :: Bytes128 - - fromStatic b128 `shouldBe` bs128 diff --git a/test/Pantry/InternalSpec.hs b/test/Pantry/InternalSpec.hs --- a/test/Pantry/InternalSpec.hs +++ b/test/Pantry/InternalSpec.hs @@ -3,8 +3,8 @@ ) where import Pantry ( runPantryApp ) -import Pantry.Internal - ( hpackVersion, makeTarRelative, normalizeParents ) +import Pantry.HPack ( hpackVersion ) +import Pantry.Internal ( makeTarRelative, normalizeParents ) import Test.Hspec spec :: Spec diff --git a/test/Pantry/TypesSpec.hs b/test/Pantry/TypesSpec.hs --- a/test/Pantry/TypesSpec.hs +++ b/test/Pantry/TypesSpec.hs @@ -10,6 +10,7 @@ ( spec ) where +import Data.Aeson.WarningParser ( WithJSONWarnings (..) ) import qualified Data.ByteString.Char8 as S8 import qualified Data.Yaml as Yaml import Distribution.Types.PackageName ( mkPackageName ) @@ -18,12 +19,9 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Pantry -import Pantry.Internal - ( Tree (..), TreeEntry (..), mkSafeFilePath, parseTree - , renderTree - ) -import Pantry.Internal.AesonExtended import qualified Pantry.SHA256 as SHA256 +import Pantry.Types + ( Tree (..), TreeEntry (..), parseTree, renderTree ) import RIO import qualified RIO.Text as T import RIO.Time ( Day (..) )