pantry-0.9.3.2/app/0000755000000000000000000000000014414332573012154 5ustar0000000000000000pantry-0.9.3.2/app/test-pretty-exceptions/0000755000000000000000000000000014566347773016657 5ustar0000000000000000pantry-0.9.3.2/app/test-pretty-exceptions/unix/0000755000000000000000000000000014414332573017622 5ustar0000000000000000pantry-0.9.3.2/app/test-pretty-exceptions/unix/System/0000755000000000000000000000000014446516353021113 5ustar0000000000000000pantry-0.9.3.2/app/test-pretty-exceptions/windows/0000755000000000000000000000000014414332573020331 5ustar0000000000000000pantry-0.9.3.2/app/test-pretty-exceptions/windows/System/0000755000000000000000000000000014414332573021615 5ustar0000000000000000pantry-0.9.3.2/attic/0000755000000000000000000000000014302665443012501 5ustar0000000000000000pantry-0.9.3.2/int/0000755000000000000000000000000014454740300012161 5ustar0000000000000000pantry-0.9.3.2/int/Pantry/0000755000000000000000000000000014566347773013463 5ustar0000000000000000pantry-0.9.3.2/src/0000755000000000000000000000000014566651633012174 5ustar0000000000000000pantry-0.9.3.2/src/Hackage/0000755000000000000000000000000014302665443013507 5ustar0000000000000000pantry-0.9.3.2/src/Hackage/Security/0000755000000000000000000000000014302665443015316 5ustar0000000000000000pantry-0.9.3.2/src/Hackage/Security/Client/0000755000000000000000000000000014302665443016534 5ustar0000000000000000pantry-0.9.3.2/src/Hackage/Security/Client/Repository/0000755000000000000000000000000014302665443020713 5ustar0000000000000000pantry-0.9.3.2/src/Hackage/Security/Client/Repository/HttpLib/0000755000000000000000000000000014520750057022257 5ustar0000000000000000pantry-0.9.3.2/src/Pantry/0000755000000000000000000000000014566666623013456 5ustar0000000000000000pantry-0.9.3.2/src/Pantry/Internal/0000755000000000000000000000000014454761646015227 5ustar0000000000000000pantry-0.9.3.2/src/unix/0000755000000000000000000000000014302665443013147 5ustar0000000000000000pantry-0.9.3.2/src/unix/System/0000755000000000000000000000000014446516353014437 5ustar0000000000000000pantry-0.9.3.2/src/windows/0000755000000000000000000000000014302665443013656 5ustar0000000000000000pantry-0.9.3.2/src/windows/System/0000755000000000000000000000000014446516353015146 5ustar0000000000000000pantry-0.9.3.2/test/0000755000000000000000000000000014302665443012354 5ustar0000000000000000pantry-0.9.3.2/test/Pantry/0000755000000000000000000000000014520750057013627 5ustar0000000000000000pantry-0.9.3.2/src/Pantry.hs0000644000000000000000000022754014566651633014017 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -- | Content addressable Haskell package management, providing for -- secure, reproducible acquisition of Haskell package contents and -- metadata. -- -- @since 0.1.0.0 module Pantry ( -- * Running PantryConfig , PackageIndexConfig (..) , HackageSecurityConfig (..) , defaultPackageIndexConfig , defaultDownloadPrefix , defaultHackageSecurityConfig , defaultCasaRepoPrefix , defaultCasaMaxPerRequest , defaultSnapshotLocation , HasPantryConfig (..) , withPantryConfig , withPantryConfig' , HpackExecutable (..) -- ** Convenience , PantryApp , runPantryApp , runPantryAppClean , runPantryAppWith , hpackExecutableL -- * Types -- ** Exceptions , PantryException (..) , Mismatch (..) , FuzzyResults (..) -- ** Cabal types , PackageName , Version , FlagName , PackageIdentifier (..) -- ** Files , FileSize (..) , RelFilePath (..) , ResolvedPath (..) , Unresolved , SafeFilePath , mkSafeFilePath -- ** Cryptography , SHA256 , TreeKey (..) , BlobKey (..) -- ** Packages , RawPackageMetadata (..) , PackageMetadata (..) , Package (..) -- ** Hackage , CabalFileInfo (..) , Revision (..) , PackageIdentifierRevision (..) , UsePreferredVersions (..) -- ** Archives , RawArchive (..) , Archive (..) , ArchiveLocation (..) -- ** Repos , Repo (..) , RepoType (..) , SimpleRepo (..) , withRepo , fetchRepos , fetchReposRaw -- ** Package location , RawPackageLocation (..) , PackageLocation (..) , toRawPL , RawPackageLocationImmutable (..) , PackageLocationImmutable (..) -- ** Snapshots , RawSnapshotLocation (..) , SnapshotLocation (..) , toRawSL , RawSnapshot (..) , Snapshot (..) , RawSnapshotPackage (..) , SnapshotPackage (..) , RawSnapshotLayer (..) , SnapshotLayer (..) , toRawSnapshotLayer , WantedCompiler (..) , SnapName (..) , snapshotLocation -- * Loading values , resolvePaths , loadPackageRaw , tryLoadPackageRawViaCasa , loadPackage , loadRawSnapshotLayer , loadSnapshotLayer , loadSnapshot , loadAndCompleteSnapshot , loadAndCompleteSnapshot' , loadAndCompleteSnapshotRaw , loadAndCompleteSnapshotRaw' , CompletedSL (..) , CompletedPLI (..) , addPackagesToSnapshot , AddPackagesConfig (..) -- * Completion functions , CompletePackageLocation (..) , completePackageLocation , completeSnapshotLocation , warnMissingCabalFile -- * Parsers , parseWantedCompiler , parseSnapName , parseRawSnapshotLocation , parsePackageIdentifierRevision , parseHackageText -- ** Cabal values , parsePackageIdentifier , parsePackageName , parsePackageNameThrowing , parseFlagName , parseVersion , parseVersionThrowing -- * Cabal helpers , packageIdentifierString , packageNameString , flagNameString , versionString , moduleNameString , CabalString (..) , toCabalStringMap , unCabalStringMap , gpdPackageIdentifier , gpdPackageName , gpdVersion -- * Package location , fetchPackages , unpackPackageLocationRaw , unpackPackageLocation , getPackageLocationName , getRawPackageLocationIdent , packageLocationIdent , packageLocationVersion , getRawPackageLocationTreeKey , getPackageLocationTreeKey -- * Cabal files , loadCabalFileRaw , loadCabalFile , loadCabalFileRawImmutable , loadCabalFileImmutable , loadCabalFilePath , findOrGenerateCabalFile , PrintWarnings (..) -- * Hackage index , updateHackageIndex , DidUpdateOccur (..) , RequireHackageIndex (..) , hackageIndexTarballL , getHackagePackageVersions , getLatestHackageVersion , getLatestHackageLocation , getLatestHackageRevision , getHackageTypoCorrections , loadGlobalHints , partitionReplacedDependencies -- * Snapshot cache , SnapshotCacheHash (..) , withSnapshotCache ) where import Casa.Client ( CasaRepoPrefix, thParserCasaRepo ) import Conduit ( (.|), mapC, mapMC, runConduitRes, sinkList, sumC ) import Control.Applicative ( empty ) import Control.Arrow ( right ) import Control.Monad.State.Strict ( State, execState, get, modify' ) import Control.Monad.Trans.Maybe ( MaybeT (..) ) #if MIN_VERSION_transformers(0,6,0) import Control.Monad.Trans.Maybe ( hoistMaybe ) #endif import Data.Aeson.Types ( Value, parseEither ) import Data.Aeson.WarningParser ( WithJSONWarnings (..) ) #if !MIN_VERSION_rio(0,1,17) import Data.Bifunctor ( bimap ) #endif import Data.Char ( isHexDigit ) import Data.Monoid ( Endo (..) ) import Data.Time ( diffUTCTime, getCurrentTime ) import qualified Data.Yaml as Yaml import Data.Yaml.Include ( decodeFileWithWarnings ) import Database.Persist.Class.PersistEntity ( entityKey ) import Distribution.PackageDescription ( FlagName, GenericPackageDescription ) import qualified Distribution.PackageDescription as D import Distribution.Parsec ( PWarning (..), showPos ) import qualified Hpack import qualified Hpack.Config as Hpack import Hpack.Error ( formatHpackError ) import Hpack.Yaml ( formatWarning ) import Network.HTTP.Download ( download, redownload ) import Pantry.Archive ( fetchArchives, findCabalOrHpackFile, getArchive , getArchiveKey, getArchivePackage ) import Pantry.Casa ( casaBlobSource, casaLookupKey, casaLookupTree ) import Pantry.HTTP ( httpSinkChecked, parseRequest ) import Pantry.Hackage ( DidUpdateOccur (..), RequireHackageIndex (..) , UsePreferredVersions (..), getHackageCabalFile , getHackagePackageVersionRevisions , getHackagePackageVersions, getHackageTarball , getHackageTarballKey, getHackageTypoCorrections , hackageIndexTarballL, htrPackage, updateHackageIndex ) import Pantry.Repo ( fetchRepos, fetchReposRaw, getRepo, getRepoKey, withRepo ) import qualified Pantry.SHA256 as SHA256 import Pantry.Storage ( getSnapshotCacheByHash, getSnapshotCacheId, getTreeForKey , initStorage, loadBlob, loadCachedTree , loadExposedModulePackages, loadPackageById, loadURLBlob , storeSnapshotModuleCache, storeTree, storeURLBlob , withStorage ) import Pantry.Tree ( rawParseGPD, unpackTree ) import Pantry.Types as P ( Archive (..), ArchiveLocation (..), BlobKey (..) , CabalFileInfo (..), CabalString (..), FileSize (..) , FuzzyResults (..), HackageSecurityConfig (..) , HasPantryConfig (..), HpackExecutable (..), Mismatch (..) , ModuleName, Package (..), PackageCabal (..) , PackageIdentifier (..), PackageIdentifierRevision (..) , PackageIndexConfig (..), PackageLocation (..) , PackageLocationImmutable (..), PackageMetadata (..) , PackageName, PantryConfig (..), PantryException (..) , PHpack (..), PrintWarnings (..), RawArchive (..) , RawPackageLocation (..), RawPackageLocationImmutable (..) , RawPackageMetadata (..), RawSnapshot (..) , RawSnapshotLayer (..), RawSnapshotLocation (..) , RawSnapshotPackage (..), RelFilePath (..), Repo (..) , RepoType (..), ResolvedPath (..), Revision (..) , SafeFilePath, SHA256, SimpleRepo (..), SnapName (..) , Snapshot (..), SnapshotCacheHash (..), SnapshotLayer (..) , SnapshotLocation (..), SnapshotPackage (..), Tree (..) , TreeEntry (..), TreeKey (..), Unresolved, Version , WantedCompiler (..), bsToBlobKey, cabalFileName , defaultHackageSecurityConfig, defaultSnapshotLocation , flagNameString, getGlobalHintsFile, mkSafeFilePath , moduleNameString, packageIdentifierString , packageNameString, parseFlagName, parseHackageText , parsePackageIdentifier, parsePackageIdentifierRevision , parsePackageName, parsePackageNameThrowing , parseRawSnapshotLocation, parseSnapName, parseTreeM , parseVersion, parseVersionThrowing, parseWantedCompiler , pirForHash, resolvePaths, snapshotLocation , toCabalStringMap, toRawPL, toRawPLI, toRawPM, toRawSL , toRawSnapshotLayer, unCabalStringMap, unSafeFilePath , versionString, warnMissingCabalFile ) import Path ( Abs, Dir, File, Path, (), filename, parent, parseAbsDir , parseRelFile, toFilePath ) import Path.IO ( doesFileExist, listDir, resolveDir' ) import RIO import qualified RIO.ByteString as B import RIO.Directory ( getAppUserDataDirectory ) import qualified RIO.FilePath as FilePath import qualified RIO.List as List import qualified RIO.Map as Map import RIO.PrettyPrint ( HasTerm (..) ) import RIO.PrettyPrint.StylesUpdate ( HasStylesUpdate (..), StylesUpdate ) import RIO.Process ( HasProcessContext (..), proc, runProcess_, withWorkingDir ) import qualified RIO.Set as Set import RIO.Text ( unpack ) import qualified RIO.Text as T import System.IO.Error ( isDoesNotExistError ) #if !MIN_VERSION_transformers(0,6,0) -- | Convert a 'Maybe' computation to 'MaybeT'. hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b hoistMaybe = MaybeT . pure #endif decodeYaml :: FilePath -> IO (Either String ([String], Value)) decodeYaml file = do bimap displayException (first formatWarnings) <$> decodeFileWithWarnings file where formatWarnings = map (formatWarning file) formatYamlParseError :: FilePath -> Yaml.ParseException -> String formatYamlParseError file e = "In respect of an Hpack defaults file:\n" <> file <> ":\n\n" <> displayException e -- | Create a new 'PantryConfig' with the given settings. For a version where -- the use of Casa (content-addressable storage archive) is optional, see -- 'withPantryConfig''. -- -- For something easier to use in simple cases, see 'runPantryApp'. -- -- @since 0.1.0.0 withPantryConfig :: HasLogFunc env => Path Abs Dir -- ^ pantry root directory, where the SQLite database and Hackage -- downloads are kept. -> PackageIndexConfig -- ^ Package index configuration. You probably want -- 'defaultPackageIndexConfig'. -> HpackExecutable -- ^ When converting an hpack @package.yaml@ file to a cabal file, what -- version of hpack should we use? -> Int -- ^ Maximum connection count -> CasaRepoPrefix -- ^ The casa pull URL e.g. https://casa.stackage.org/v1/pull. -> Int -- ^ Max casa keys to pull per request. -> (SnapName -> RawSnapshotLocation) -- ^ The location of snapshot synonyms -> (PantryConfig -> RIO env a) -- ^ What to do with the config -> RIO env a withPantryConfig root pic he count pullURL maxPerRequest = withPantryConfig' root pic he count (Just (pullURL, maxPerRequest)) -- | Create a new 'PantryConfig' with the given settings. -- -- For something easier to use in simple cases, see 'runPantryApp'. -- -- @since 0.8.3 withPantryConfig' :: HasLogFunc env => Path Abs Dir -- ^ pantry root directory, where the SQLite database and Hackage -- downloads are kept. -> PackageIndexConfig -- ^ Package index configuration. You probably want -- 'defaultPackageIndexConfig'. -> HpackExecutable -- ^ When converting an hpack @package.yaml@ file to a cabal file, -- what version of hpack should we use? -> Int -- ^ Maximum connection count -> 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. -> (SnapName -> RawSnapshotLocation) -- ^ The location of snapshot synonyms -> (PantryConfig -> RIO env a) -- ^ What to do with the config -> RIO env a withPantryConfig' root pic he count mCasaConfig snapLoc inner = do env <- ask pantryRelFile <- parseRelFile "pantry.sqlite3" -- Silence persistent's logging output, which is really noisy runRIO (mempty :: LogFunc) $ initStorage (root pantryRelFile) $ \storage -> runRIO env $ do ur <- newMVar True ref1 <- newIORef mempty ref2 <- newIORef mempty inner PantryConfig { pcPackageIndex = pic , pcHpackExecutable = he , pcRootDir = root , pcStorage = storage , pcUpdateRef = ur , pcConnectionCount = count , pcParsedCabalFilesRawImmutable = ref1 , pcParsedCabalFilesMutable = ref2 , pcCasaConfig = mCasaConfig , pcSnapshotLocation = snapLoc } -- | Default pull URL for Casa. -- -- @since 0.1.1.1 defaultCasaRepoPrefix :: CasaRepoPrefix defaultCasaRepoPrefix = $(thParserCasaRepo "https://casa.stackage.org") -- | Default max keys to pull per request. -- -- @since 0.1.1.1 defaultCasaMaxPerRequest :: Int defaultCasaMaxPerRequest = 1280 -- | Default 'PackageIndexConfig' value using the official Hackage server. -- -- @since 0.6.0 defaultPackageIndexConfig :: PackageIndexConfig defaultPackageIndexConfig = PackageIndexConfig { picDownloadPrefix = defaultDownloadPrefix , picHackageSecurityConfig = defaultHackageSecurityConfig } -- | The download prefix for the official Hackage server. -- -- @since 0.6.0 defaultDownloadPrefix :: Text defaultDownloadPrefix = "https://hackage.haskell.org/" -- | Returns the latest version of the given package available from -- Hackage. -- -- @since 0.1.0.0 getLatestHackageVersion :: (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> PackageName -- ^ package name -> UsePreferredVersions -> RIO env (Maybe PackageIdentifierRevision) getLatestHackageVersion req name preferred = ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions req preferred name where go (version, m) = do (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m pure $ PackageIdentifierRevision name version $ CFIHash sha $ Just size -- | Returns location of the latest version of the given package available from -- Hackage. -- -- @since 0.1.0.0 getLatestHackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RequireHackageIndex -> PackageName -- ^ package name -> UsePreferredVersions -> RIO env (Maybe PackageLocationImmutable) getLatestHackageLocation req name preferred = do mversion <- fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions req preferred name let mVerCfKey = do (version, revisions) <- mversion (_rev, cfKey) <- fst <$> Map.maxViewWithKey revisions pure (version, cfKey) forM mVerCfKey $ \(version, cfKey@(BlobKey sha size)) -> do let pir = PackageIdentifierRevision name version (CFIHash sha (Just size)) treeKey' <- getHackageTarballKey pir pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' -- | Returns the latest revision of the given package version available from -- Hackage. -- -- @since 0.1.0.0 getLatestHackageRevision :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RequireHackageIndex -> PackageName -- ^ package name -> Version -> RIO env (Maybe (Revision, BlobKey, TreeKey)) getLatestHackageRevision req name version = do revisions <- getHackagePackageVersionRevisions req name version case fst <$> Map.maxViewWithKey revisions of Nothing -> pure Nothing Just (revision, cfKey@(BlobKey sha size)) -> do let cfi = CFIHash sha (Just size) treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) pure $ Just (revision, cfKey, treeKey') -- | Fetch keys and blobs and insert into the database where possible. fetchTreeKeys :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [RawPackageLocationImmutable] -> RIO env () fetchTreeKeys treeKeys = do -- Find all tree keys that are missing from the database. packageLocationsMissing :: [RawPackageLocationImmutable] <- withStorage (filterM (fmap isNothing . maybe (pure Nothing) getTreeForKey . getRawTreeKey) treeKeys) pullTreeStart <- liftIO getCurrentTime -- Pull down those tree keys from Casa, automatically inserting into -- our local database. treeKeyBlobs :: Map TreeKey P.Tree <- handleAny (const mempty) (fmap Map.fromList (withStorage (runConduitRes (casaBlobSource (fmap unTreeKey (mapMaybe getRawTreeKey packageLocationsMissing)) .| mapMC parseTreeM .| sinkList)))) pullTreeEnd <- liftIO getCurrentTime let pulledPackages = mapMaybe (\treeKey' -> List.find ((== Just treeKey') . getRawTreeKey) packageLocationsMissing) (Map.keys treeKeyBlobs) -- Pull down all unique file blobs. let uniqueFileBlobKeys :: Set BlobKey uniqueFileBlobKeys = foldMap (\(P.TreeMap files) -> Set.fromList (map teBlob (toList files))) treeKeyBlobs pullBlobStart <- liftIO getCurrentTime mpulledBlobKeys :: Maybe Int <- handleAny (const (pure Nothing)) (fmap Just (withStorage (runConduitRes (casaBlobSource uniqueFileBlobKeys .| mapC (const 1) .| sumC)))) for_ mpulledBlobKeys $ \pulledBlobKeys -> do pullBlobEnd <- liftIO getCurrentTime logDebug ("Pulled from Casa: " <> mconcat (List.intersperse ", " (map display pulledPackages)) <> " (" <> display (T.pack (show (diffUTCTime pullTreeEnd pullTreeStart))) <> "), " <> plural pulledBlobKeys "file" <> " (" <> display (T.pack (show (diffUTCTime pullBlobEnd pullBlobStart))) <> ")") -- Store the tree for each missing package. for_ packageLocationsMissing (\rawPackageLocationImmutable -> let mkey = getRawTreeKey rawPackageLocationImmutable in case mkey of Nothing -> logDebug ("Ignoring package with no tree key " <> display rawPackageLocationImmutable <> ", can't look in Casa for it.") Just key -> case Map.lookup key treeKeyBlobs of Nothing -> logDebug ("Package key " <> display key <> " (" <> display rawPackageLocationImmutable <> ") not returned from Casa.") Just tree -> do identifier <- getRawPackageLocationIdent rawPackageLocationImmutable case findCabalOrHpackFile rawPackageLocationImmutable tree of Just buildFile -> withStorage $ do ecachedTree <- loadCachedTree tree case ecachedTree of Left e -> lift $ logWarn ("Loading cached tree after download from Casa failed on " <> display rawPackageLocationImmutable <> ": " <> displayShow e) Right cachedTree -> void $ storeTree rawPackageLocationImmutable identifier cachedTree buildFile Nothing -> logWarn ("Unable to find build file for package: " <> display rawPackageLocationImmutable)) where unTreeKey :: TreeKey -> BlobKey unTreeKey (P.TreeKey blobKey) = blobKey -- | Download all of the packages provided into the local cache without -- performing any unpacking. Can be useful for build tools wanting to prefetch -- or provide an offline mode. -- -- @since 0.1.0.0 fetchPackages :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f) => f PackageLocationImmutable -> RIO env () fetchPackages pls = do fetchTreeKeys (fmap toRawPLI (toList pls)) traverseConcurrently_ (void . uncurry getHackageTarball) hackages -- TODO in the future, be concurrent in these as well fetchArchives archives fetchRepos repos where s x = Endo (x:) run (Endo f) = f [] (hackagesE, archivesE, reposE) = foldMap go pls hackages = run hackagesE archives = run archivesE repos = run reposE go (PLIHackage ident cfHash tree) = (s (toPir ident cfHash, Just tree), mempty, mempty) go (PLIArchive archive pm) = (mempty, s (archive, pm), mempty) go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) toPir (PackageIdentifier name ver) (BlobKey sha size) = PackageIdentifierRevision name ver (CFIHash sha (Just size)) -- | Unpack a given 'RawPackageLocationImmutable' into the given directory. Does -- not generate any extra subdirectories. -- -- @since 0.1.0.0 unpackPackageLocationRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ unpack directory -> RawPackageLocationImmutable -> RIO env () unpackPackageLocationRaw fp loc = loadPackageRaw loc >>= unpackTree loc fp . packageTree -- | Unpack a given 'PackageLocationImmutable' into the given directory. Does -- not generate any extra subdirectories. -- -- @since 0.1.0.0 unpackPackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ unpack directory -> PackageLocationImmutable -> RIO env () unpackPackageLocation fp loc = loadPackage loc >>= unpackTree (toRawPLI loc) fp . packageTree -- | Load the cabal file for the given 'PackageLocationImmutable'. -- -- This function ignores all warnings. -- -- @since 0.1.0.0 loadCabalFileImmutable :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env GenericPackageDescription loadCabalFileImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFileBytes loc (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs let pm = case loc of PLIHackage (PackageIdentifier name version) _cfHash mtree -> PackageMetadata { pmIdent = PackageIdentifier name version , pmTreeKey = mtree } PLIArchive _ pm' -> pm' PLIRepo _ pm' -> pm' let exc = MismatchedPackageMetadata (toRawPLI loc) (toRawPM pm) Nothing (gpdPackageIdentifier gpd) PackageIdentifier name ver = pmIdent pm maybe (throwIO exc) pure $ do guard $ name == gpdPackageName gpd guard $ ver == gpdVersion gpd pure gpd where withCache inner = do let rawLoc = toRawPLI loc ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable m0 <- readIORef ref case Map.lookup rawLoc m0 of Just x -> pure x Nothing -> do x <- inner atomicModifyIORef' ref $ \m -> (Map.insert rawLoc x m, x) -- | Load the cabal file for the given 'RawPackageLocationImmutable'. -- -- This function ignores all warnings. -- -- Note that, for now, this will not allow support for hpack files in these -- package locations. Instead, all @PackageLocationImmutable@s will require a -- .cabal file. This may be relaxed in the future. -- -- @since 0.1.0.0 loadCabalFileRawImmutable :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env GenericPackageDescription loadCabalFileRawImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadRawCabalFileBytes loc (_warnings, gpd) <- rawParseGPD (Left loc) bs let rpm = case loc of RPLIHackage (PackageIdentifierRevision name version _cfi) mtree -> RawPackageMetadata { rpmName = Just name , rpmVersion = Just version , rpmTreeKey = mtree } RPLIArchive _ rpm' -> rpm' RPLIRepo _ rpm' -> rpm' let exc = MismatchedPackageMetadata loc rpm Nothing (gpdPackageIdentifier gpd) maybe (throwIO exc) pure $ do guard $ maybe True (== gpdPackageName gpd) (rpmName rpm) guard $ maybe True (== gpdVersion gpd) (rpmVersion rpm) pure gpd where withCache inner = do ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable m0 <- readIORef ref case Map.lookup loc m0 of Just x -> pure x Nothing -> do x <- inner atomicModifyIORef' ref $ \m -> (Map.insert loc x m, x) -- | Same as 'loadCabalFileRawImmutable', but takes a 'RawPackageLocation'. -- Never prints warnings, see 'loadCabalFilePath' for that. -- -- @since 0.8.0 loadCabalFileRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Maybe Text -- ^ The program name used by Hpack (the library), defaults to \"hpack\". -> RawPackageLocation -> RIO env GenericPackageDescription loadCabalFileRaw _ (RPLImmutable loc) = loadCabalFileRawImmutable loc loadCabalFileRaw progName (RPLMutable rfp) = do (gpdio, _, _) <- loadCabalFilePath progName (resolvedAbsolute rfp) liftIO $ gpdio NoPrintWarnings -- | Same as 'loadCabalFileImmutable', but takes a 'PackageLocation'. Never -- prints warnings, see 'loadCabalFilePath' for that. -- -- @since 0.8.0 loadCabalFile :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Maybe Text -- ^ The program name used by Hpack (the library), defaults to \"hpack\". -> PackageLocation -> RIO env GenericPackageDescription loadCabalFile _ (PLImmutable loc) = loadCabalFileImmutable loc loadCabalFile progName (PLMutable rfp) = do (gpdio, _, _) <- loadCabalFilePath progName (resolvedAbsolute rfp) liftIO $ gpdio NoPrintWarnings -- | Parse the Cabal file for the package inside the given directory. Performs -- various sanity checks, such as the file name being correct and having only a -- single Cabal file. -- -- @since 0.8.0 loadCabalFilePath :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Maybe Text -- ^ The program name used by Hpack (the library), defaults to \"hpack\". -> Path Abs Dir -- ^ project directory, with a cabal file or hpack file -> RIO env ( PrintWarnings -> IO GenericPackageDescription , PackageName , Path Abs File ) loadCabalFilePath progName dir = do ref <- view $ pantryConfigL.to pcParsedCabalFilesMutable mcached <- Map.lookup dir <$> readIORef ref case mcached of Just triple -> pure triple Nothing -> do (name, cabalfp) <- findOrGenerateCabalFile progName dir gpdRef <- newIORef Nothing run <- askRunInIO let gpdio = run . getGPD cabalfp gpdRef triple = (gpdio, name, cabalfp) atomicModifyIORef' ref $ \m -> (Map.insert dir triple m, triple) where getGPD cabalfp gpdRef printWarnings = do mpair <- readIORef gpdRef (warnings0, gpd) <- case mpair of Just pair -> pure pair Nothing -> do bs <- liftIO $ B.readFile $ toFilePath cabalfp (warnings0, gpd) <- rawParseGPD (Right cabalfp) bs checkCabalFileName (gpdPackageName gpd) cabalfp pure (warnings0, gpd) warnings <- case printWarnings of YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings0 $> [] NoPrintWarnings -> pure warnings0 writeIORef gpdRef $ Just (warnings, gpd) pure gpd toPretty :: Path Abs File -> PWarning -> Utf8Builder toPretty src (PWarning _type pos msg) = "Cabal file warning in " <> fromString (toFilePath src) <> "@" <> fromString (showPos pos) <> ": " <> fromString msg -- | Check if the given name in the @Package@ matches the name of the .cabal -- file checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () checkCabalFileName name cabalfp = do -- Previously, we just use parsePackageNameFromFilePath. However, that can -- lead to confusing error messages. See: -- https://github.com/commercialhaskell/stack/issues/895 let expected = T.unpack $ unSafeFilePath $ cabalFileName name when (expected /= toFilePath (filename cabalfp)) $ throwM $ MismatchedCabalName cabalfp name -- | Get the file name for the Cabal file in the given directory. -- -- If no Cabal file is present, or more than one is present, an exception is -- thrown via 'throwM'. -- -- If the directory contains a file named package.yaml, Hpack is used to -- generate a Cabal file from it. -- -- @since 0.8.0 findOrGenerateCabalFile :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Maybe Text -- ^ The program name used by Hpack (the library), defaults to \"hpack\". -> Path Abs Dir -- ^ package directory -> RIO env (PackageName, Path Abs File) findOrGenerateCabalFile progName pkgDir = do let hpackProgName = fromString . unpack <$> progName hpack hpackProgName pkgDir (_, allFiles) <- listDir pkgDir `catchIO` \e -> if isDoesNotExistError e then throwIO $ NoLocalPackageDirFound pkgDir else throwIO e let files = filter (flip hasExtension "cabal" . toFilePath) allFiles -- If there are multiple files, ignore files that start with -- ".". On unixlike environments these are hidden, and this -- character is not valid in package names. The main goal is -- to ignore emacs lock files - see -- https://github.com/commercialhaskell/stack/issues/1897. let isHidden ('.':_) = True isHidden _ = False case filter (not . isHidden . toFilePath . filename) files of [] -> throwIO $ NoCabalFileFound pkgDir [x] -> maybe (throwIO $ InvalidCabalFilePath x) (\pn -> pure (pn, x)) $ List.stripSuffix ".cabal" (toFilePath (filename x)) >>= parsePackageName _:_ -> throwIO $ MultipleCabalFilesFound pkgDir files where hasExtension fp x = FilePath.takeExtension fp == "." ++ x -- | Generate Cabal file from package.yaml, if necessary. hpack :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Maybe Hpack.ProgramName -- ^ The program name used by Hpack (the library). -> Path Abs Dir -> RIO env () hpack progName pkgDir = do packageConfigRelFile <- parseRelFile Hpack.packageConfig let hpackFile = pkgDir packageConfigRelFile mHpackProgName = maybe id Hpack.setProgramName progName exists <- liftIO $ doesFileExist hpackFile when exists $ do logDebug $ "Running Hpack on " <> fromString (toFilePath hpackFile) he <- view $ pantryConfigL.to pcHpackExecutable case he of HpackBundled -> liftIO ( Hpack.hpackResultWithError $ mHpackProgName $ Hpack.setDecode decodeYaml $ Hpack.setFormatYamlParseError formatYamlParseError $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions ) >>= \ case Left err -> throwIO (HpackLibraryException hpackFile $ formatHpackError (fromMaybe "hpack" progName) err) Right r -> do 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 -> catchAny ( withWorkingDir (toFilePath pkgDir) $ proc command [] runProcess_ ) ( throwIO . HpackExeException command pkgDir) -- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'. -- -- @since 0.1.0.0 gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier gpdPackageIdentifier = D.package . D.packageDescription -- | Get the 'PackageName' from a 'GenericPackageDescription'. -- -- @since 0.1.0.0 gpdPackageName :: GenericPackageDescription -> PackageName gpdPackageName = pkgName . gpdPackageIdentifier -- | Get the 'Version' from a 'GenericPackageDescription'. -- -- @since 0.1.0.0 gpdVersion :: GenericPackageDescription -> Version gpdVersion = pkgVersion . gpdPackageIdentifier loadCabalFileBytes :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env ByteString -- Just ignore the mtree for this. Safe assumption: someone who filled in the -- TreeKey also filled in the cabal file hash, and that's a more efficient -- lookup mechanism. loadCabalFileBytes (PLIHackage pident cfHash _mtree) = getHackageCabalFile (pirForHash pident cfHash) loadCabalFileBytes pl = do package <- loadPackage pl let sfp = cabalFileName $ pkgName $ packageIdent package cabalBlobKey <- case packageCabalEntry package of PCHpack pcHpack -> pure $ teBlob . phGenerated $ pcHpack PCCabalFile (TreeEntry blobKey _) -> pure blobKey mbs <- withStorage $ loadBlob cabalBlobKey case mbs of Nothing -> do throwIO $ TreeReferencesMissingBlob (toRawPLI pl) sfp cabalBlobKey Just bs -> pure bs -- FIXME: to be removed loadRawCabalFileBytes :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env ByteString -- Just ignore the mtree for this. Safe assumption: someone who filled -- in the TreeKey also filled in the cabal file hash, and that's a -- more efficient lookup mechanism. loadRawCabalFileBytes (RPLIHackage pir _mtree) = getHackageCabalFile pir loadRawCabalFileBytes pl = do package <- loadPackageRaw pl let sfp = cabalFileName $ pkgName $ packageIdent package TreeEntry cabalBlobKey _ft = case packageCabalEntry package of PCCabalFile cabalTE -> cabalTE PCHpack hpackCE -> phGenerated hpackCE mbs <- withStorage $ loadBlob cabalBlobKey case mbs of Nothing -> do throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey Just bs -> pure bs -- | Load a 'Package' from a 'PackageLocationImmutable'. -- -- @since 0.1.0.0 loadPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env Package loadPackage = loadPackageRaw . toRawPLI -- | Load a 'Package' from a 'RawPackageLocationImmutable'. -- -- Load the package either from the local DB, Casa, or as a last resort, the -- third party (hackage, archive or repo). -- -- @since 0.1.0.0 loadPackageRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env Package loadPackageRaw rpli = do case getRawTreeKey rpli of Just treeKey' -> do mpackage <- tryLoadPackageRawViaDbOrCasa rpli treeKey' maybe loadPackageRawViaThirdParty pure mpackage Nothing -> loadPackageRawViaThirdParty where loadPackageRawViaThirdParty = do logDebug ("Loading package from third-party: " <> display rpli) case rpli of RPLIHackage pir mtree -> htrPackage <$> getHackageTarball pir mtree RPLIArchive archive pm -> getArchivePackage rpli archive pm RPLIRepo repo rpm -> getRepo repo rpm -- | Try to load a package via the database or Casa. tryLoadPackageRawViaDbOrCasa :: (HasLogFunc env, HasPantryConfig env, HasProcessContext env) => RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package) tryLoadPackageRawViaDbOrCasa rpli treeKey' = runMaybeT $ tryViaLocalDb <|> tryCasa where tryViaLocalDb = do package <- MaybeT $ tryLoadPackageRawViaLocalDb rpli treeKey' lift $ logDebug ("Loaded package from Pantry: " <> display rpli) pure package tryCasa = do void $ MaybeT $ view $ pantryConfigL . to pcCasaConfig package <- MaybeT $ tryLoadPackageRawViaCasa rpli treeKey' lift $ logDebug ("Loaded package from Casa: " <> display rpli) pure package -- | Maybe load the package from Casa. tryLoadPackageRawViaCasa :: (HasLogFunc env, HasPantryConfig env, HasProcessContext env) => RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package) tryLoadPackageRawViaCasa rlpi treeKey' = runMaybeT $ do (treeKey'', _) <- MaybeT $ casaLookupTree treeKey' lift $ fetchTreeKeys [rlpi] tryViaLocalDb treeKey'' <|> warn treeKey'' where tryViaLocalDb = MaybeT . tryLoadPackageRawViaLocalDb rlpi warn treeKey'' = do lift $ logWarn $ "Did not find tree key in DB after pulling it from Casa: " <> display treeKey'' <> " (for " <> display rlpi <> ")" empty -- | Maybe load the package from the local database. tryLoadPackageRawViaLocalDb :: (HasLogFunc env, HasPantryConfig env, HasProcessContext env) => RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package) tryLoadPackageRawViaLocalDb rlpi treeKey' = runMaybeT $ do treeId <- MaybeT $ withStorage (getTreeForKey treeKey') lift $ withStorage (loadPackageById rlpi (entityKey treeId)) -- | Complete package location, plus whether the package has a cabal file. This -- is relevant to reproducibility, see -- -- -- @since 0.4.0.0 data CompletePackageLocation = CompletePackageLocation { cplComplete :: !PackageLocationImmutable , cplHasCabalFile :: !Bool } -- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. -- -- @since 0.1.0.0 completePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env CompletePackageLocation completePackageLocation (RPLIHackage (PackageIdentifierRevision n v (CFIHash sha (Just size))) (Just tk)) = pure CompletePackageLocation { cplComplete = PLIHackage (PackageIdentifier n v) (BlobKey sha size) tk , cplHasCabalFile = True } completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name version cfi0) _) = do logDebug $ "Completing package location information from " <> display pir0 (pir, cfKey) <- case cfi0 of CFIHash sha (Just size) -> pure (pir0, BlobKey sha size) _ -> do bs <- getHackageCabalFile pir0 let size = FileSize (fromIntegral (B.length bs)) sha = SHA256.hashBytes bs cfi = CFIHash sha (Just size) pir = PackageIdentifierRevision name version cfi logDebug $ "Added in cabal file hash: " <> display pir pure (pir, BlobKey sha size) treeKey' <- getHackageTarballKey pir pure CompletePackageLocation { cplComplete = PLIHackage (PackageIdentifier name version) cfKey treeKey' , cplHasCabalFile = True } completePackageLocation pl@(RPLIArchive archive rpm) = do mpackage <- case rpmTreeKey rpm of Just treeKey' -> tryLoadPackageRawViaDbOrCasa pl treeKey' Nothing -> pure Nothing case (,,) <$> raHash archive <*> raSize archive <*> mpackage of Just (sha256, fileSize, package) -> do let RawArchive loc _ _ subdir = archive pure CompletePackageLocation { cplComplete = PLIArchive (Archive loc sha256 fileSize subdir) (packagePM package) , cplHasCabalFile = case packageCabalEntry package of PCCabalFile{} -> True PCHpack{} -> False } Nothing -> byThirdParty (isJust mpackage) where byThirdParty warnAboutMissingSizeSha = do (sha, size, package, _cachedTree) <- getArchive pl archive rpm when warnAboutMissingSizeSha (warnWith sha size) -- (getArchive checks archive and package metadata) let RawArchive loc _ _ subdir = archive logDebug $ fromString $ show (pl, sha, size, package) pure CompletePackageLocation { cplComplete = PLIArchive (Archive loc sha size subdir) (packagePM package) , cplHasCabalFile = case packageCabalEntry package of PCCabalFile{} -> True PCHpack{} -> False } warnWith sha size = logWarn (mconcat [ "The package " , display pl , " is available from the local content-addressable storage database, \n" , "but we can't use it unless you specify the size and hash for this package.\n" , "Add the following to your package description:\n" , "\nsize: " <> display size , "\nsha256: " <> display sha ]) completePackageLocation pl@(RPLIRepo repo rpm) = do unless (isSHA1 (repoCommit repo)) $ throwIO $ CannotCompleteRepoNonSHA1 repo completePM repo pl rpm where isSHA1 t = T.length t == 40 && T.all isHexDigit t completePM :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageLocationImmutable -> RawPackageMetadata -> RIO env CompletePackageLocation completePM repo plOrig rpm@(RawPackageMetadata mn mv mtk) | Just n <- mn, Just v <- mv, Just tk <- mtk = do let pm = PackageMetadata (PackageIdentifier n v) tk pure CompletePackageLocation { cplComplete = PLIRepo repo pm -- This next bit is a hack: we don't know for certain that this is the -- case. However, for the use case where complete package metadata has -- been supplied, we'll assume there's a cabal file for purposes of -- generating a deprecation warning. , cplHasCabalFile = True } | otherwise = do package <- loadPackageRaw plOrig let pm = packagePM package let isSame x (Just y) = x == y isSame _ _ = True allSame = isSame (pkgName $ pmIdent pm) (rpmName rpm) && isSame (pkgVersion $ pmIdent pm) (rpmVersion rpm) && isSame (pmTreeKey pm) (rpmTreeKey rpm) if allSame then pure CompletePackageLocation { cplComplete = PLIRepo repo pm , cplHasCabalFile = case packageCabalEntry package of PCCabalFile{} -> True PCHpack{} -> False } else throwIO $ CompletePackageMetadataMismatch plOrig pm packagePM :: Package -> PackageMetadata packagePM package = PackageMetadata { pmIdent = packageIdent package , pmTreeKey = packageTreeKey package } -- | Add in hashes to make a 'SnapshotLocation' reproducible. -- -- @since 0.1.0.0 completeSnapshotLocation :: (HasPantryConfig env, HasLogFunc env) => RawSnapshotLocation -> RIO env SnapshotLocation completeSnapshotLocation (RSLCompiler c) = pure $ SLCompiler c completeSnapshotLocation (RSLFilePath f) = pure $ SLFilePath f completeSnapshotLocation (RSLUrl url (Just blobKey)) = pure $ SLUrl url blobKey completeSnapshotLocation (RSLUrl url Nothing) = do bs <- loadFromURL url Nothing pure $ SLUrl url (bsToBlobKey bs) completeSnapshotLocation (RSLSynonym syn) = completeSnapshotLocation =<< snapshotLocation syn traverseConcurrently_ :: (Foldable f, HasPantryConfig env) => (a -> RIO env ()) -- ^ action to perform -> f a -- ^ input values -> RIO env () traverseConcurrently_ f t0 = do cnt <- view $ pantryConfigL.to pcConnectionCount traverseConcurrentlyWith_ cnt f t0 traverseConcurrentlyWith_ :: (MonadUnliftIO m, Foldable f) => Int -- ^ concurrent workers -> (a -> m ()) -- ^ action to perform -> f a -- ^ input values -> m () traverseConcurrentlyWith_ count f t0 = do queue <- newTVarIO $ toList t0 replicateConcurrently_ count $ fix $ \loop -> join $ atomically $ do toProcess <- readTVar queue case toProcess of [] -> pure (pure ()) (x:rest) -> do writeTVar queue rest pure $ do f x loop -- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'. -- -- @since 0.1.0.0 loadSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation -> RIO env RawSnapshot loadSnapshotRaw loc = do eres <- loadRawSnapshotLayer loc case eres of Left wc -> pure RawSnapshot { rsCompiler = wc , rsPackages = mempty , rsDrop = mempty } Right (rsl, _) -> do snap0 <- loadSnapshotRaw $ rslParent rsl (packages, unused) <- addPackagesToSnapshot (display loc) (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl , apcFlags = rslFlags rsl , apcHiddens = rslHidden rsl , apcGhcOptions = rslGhcOptions rsl } (rsPackages snap0) warnUnusedAddPackagesConfig (display loc) unused pure RawSnapshot { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) , rsPackages = packages , rsDrop = apcDrop unused } -- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'. -- -- @since 0.1.0.0 loadSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation -> RIO env RawSnapshot loadSnapshot loc = do eres <- loadSnapshotLayer loc case eres of Left wc -> pure RawSnapshot { rsCompiler = wc , rsPackages = mempty , rsDrop = mempty } Right rsl -> do snap0 <- loadSnapshotRaw $ rslParent rsl (packages, unused) <- addPackagesToSnapshot (display loc) (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl , apcFlags = rslFlags rsl , apcHiddens = rslHidden rsl , apcGhcOptions = rslGhcOptions rsl } (rsPackages snap0) warnUnusedAddPackagesConfig (display loc) unused pure RawSnapshot { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) , rsPackages = packages , rsDrop = apcDrop unused } -- | A completed package location, including the original raw and completed -- information. -- -- @since 0.1.0.0 data CompletedPLI = CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable -- | A completed snapshot location, including the original raw and completed -- information. -- -- @since 0.1.0.0 data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation -- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting any -- incomplete package locations. Debug output will include the raw snapshot -- layer. -- -- @since 0.1.0.0 loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) loadAndCompleteSnapshot = loadAndCompleteSnapshot' True -- | As for 'loadAndCompleteSnapshot' but allows toggling of the debug output of -- the raw snapshot layer. -- -- @since 0.5.7 loadAndCompleteSnapshot' :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Bool -- ^ Debug output includes the raw snapshot layer -> SnapshotLocation -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) loadAndCompleteSnapshot' debugRSL loc = loadAndCompleteSnapshotRaw' debugRSL (toRawSL loc) -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations. Debug output will include the raw snapshot -- layer. -- -- @since 0.1.0.0 loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) loadAndCompleteSnapshotRaw = loadAndCompleteSnapshotRaw' True -- | As for 'loadAndCompleteSnapshotRaw' but allows toggling of the debug output -- of the raw snapshot layer. -- -- @since 0.5.7 loadAndCompleteSnapshotRaw' :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Bool -- ^ Debug output includes the raw snapshot layer -> RawSnapshotLocation -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) loadAndCompleteSnapshotRaw' debugRSL rawLoc cacheSL cachePL = do eres <- case Map.lookup rawLoc cacheSL of Just loc -> right (, CompletedSL rawLoc loc) <$> loadSnapshotLayer loc Nothing -> loadRawSnapshotLayer rawLoc case eres of Left wc -> let snapshot = Snapshot { snapshotCompiler = wc , snapshotPackages = mempty , snapshotDrop = mempty } in pure (snapshot, [CompletedSL (RSLCompiler wc) (SLCompiler wc)], []) Right (rsl, sloc) -> do (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw' debugRSL (rslParent rsl) cacheSL cachePL when debugRSL $ logDebug $ fromString $ show rsl (packages, completed, unused) <- addAndCompletePackagesToSnapshot rawLoc cachePL (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl , apcFlags = rslFlags rsl , apcHiddens = rslHidden rsl , apcGhcOptions = rslGhcOptions rsl } (snapshotPackages snap0) warnUnusedAddPackagesConfig (display rawLoc) unused let snapshot = Snapshot { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl) , snapshotPackages = packages , snapshotDrop = apcDrop unused } pure (snapshot, sloc : slocs,completed0 ++ completed) data SingleOrNot a = Single !a | Multiple !a !a !([a] -> [a]) instance Semigroup (SingleOrNot a) where Single a <> Single b = Multiple a b id Single a <> Multiple b c d = Multiple a b ((c:) . d) Multiple a b c <> Single d = Multiple a b (c . (d:)) Multiple a b c <> Multiple d e f = Multiple a b (c . (d:) . (e:) . f) sonToEither :: (k, SingleOrNot a) -> Either (k, a) (k, [a]) sonToEither (k, Single a) = Left (k, a) sonToEither (k, Multiple a b c) = Right (k, a : b : c []) -- | Package settings to be passed to 'addPackagesToSnapshot'. -- -- @since 0.1.0.0 data AddPackagesConfig = AddPackagesConfig { apcDrop :: !(Set PackageName) , apcFlags :: !(Map PackageName (Map FlagName Bool)) , apcHiddens :: !(Map PackageName Bool) , apcGhcOptions :: !(Map PackageName [Text]) } -- | Does not warn about drops, those are allowed in order to ignore global -- packages. warnUnusedAddPackagesConfig :: HasLogFunc env => Utf8Builder -- ^ source -> AddPackagesConfig -> RIO env () warnUnusedAddPackagesConfig source (AddPackagesConfig _drops flags hiddens options) = do unless (null ls) $ do logWarn $ "Some warnings discovered when adding packages to snapshot (" <> source <> ")" traverse_ logWarn ls where ls = concat [flags', hiddens', options'] flags' = map (\pn -> "Setting flags for nonexistent package: " <> fromString (packageNameString pn)) (Map.keys flags) hiddens' = map (\pn -> "Hiding nonexistent package: " <> fromString (packageNameString pn)) (Map.keys hiddens) options' = map (\pn -> "Setting options for nonexistent package: " <> fromString (packageNameString pn)) (Map.keys options) -- | Add more packages to a snapshot -- -- Note that any settings on a parent flag which is being replaced will be -- ignored. For example, if package @foo@ is in the parent and has flag @bar@ -- set, and @foo@ also appears in new packages, then @bar@ will no longer be -- set. -- -- Returns any of the 'AddPackagesConfig' values not used. -- -- @since 0.1.0.0 addPackagesToSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Utf8Builder -- ^ Text description of where these new packages are coming from, for -- error messages only -> [RawPackageLocationImmutable] -- ^ new packages -> AddPackagesConfig -> Map PackageName RawSnapshotPackage -- ^ packages from parent -> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig) addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens options) old = do new' <- for newPackages $ \loc -> do name <- getPackageLocationName loc pure (name, RawSnapshotPackage { rspLocation = loc , rspFlags = Map.findWithDefault mempty name flags , rspHidden = Map.findWithDefault False name hiddens , rspGhcOptions = Map.findWithDefault [] name options }) let (newSingles, newMultiples) = partitionEithers $ map sonToEither $ Map.toList $ Map.fromListWith (<>) $ map (second Single) new' unless (null newMultiples) $ throwIO $ DuplicatePackageNames source $ map (second (map rspLocation)) newMultiples let new = Map.fromList newSingles allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) allPackages = flip Map.mapWithKey allPackages0 $ \name rsp -> rsp { rspFlags = Map.findWithDefault (rspFlags rsp) name flags , rspHidden = Map.findWithDefault (rspHidden rsp) name hiddens , rspGhcOptions = Map.findWithDefault (rspGhcOptions rsp) name options } unused = AddPackagesConfig (drops `Set.difference` Map.keysSet old) (flags `Map.difference` allPackages) (hiddens `Map.difference` allPackages) (options `Map.difference` allPackages) pure (allPackages, unused) cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Map RawPackageLocationImmutable PackageLocationImmutable -> RawPackageLocationImmutable -> RIO env (Maybe PackageLocationImmutable) cachedSnapshotCompletePackageLocation cachePackages rpli = runMaybeT $ tryCache <|> tryCpl where tryCache = hoistMaybe $ Map.lookup rpli cachePackages tryCpl = do cpl <- lift $ completePackageLocation rpli if cplHasCabalFile cpl then pure (cplComplete cpl) else empty -- | Add more packages to a snapshot completing their locations if needed -- -- Note that any settings on a parent flag which is being replaced will be -- ignored. For example, if package @foo@ is in the parent and has flag @bar@ -- set, and @foo@ also appears in new packages, then @bar@ will no longer be -- set. -- -- Returns any of the 'AddPackagesConfig' values not used and also all -- non-trivial package location completions. -- -- @since 0.1.0.0 addAndCompletePackagesToSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation -- ^ Text description of where these new packages are coming from, for -- error messages only -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file -> [RawPackageLocationImmutable] -- ^ new packages -> AddPackagesConfig -> Map PackageName SnapshotPackage -- ^ packages from parent -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig drops flags hiddens options) old = do let source = display loc addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => ([(PackageName, SnapshotPackage)],[CompletedPLI]) -> RawPackageLocationImmutable -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) addPackage (ps, completed) rawLoc = do mcomplLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc case mcomplLoc of Nothing -> do warnMissingCabalFile rawLoc pure (ps, completed) Just complLoc -> do let PackageIdentifier name _ = packageLocationIdent complLoc p = (name, SnapshotPackage { spLocation = complLoc , spFlags = Map.findWithDefault mempty name flags , spHidden = Map.findWithDefault False name hiddens , spGhcOptions = Map.findWithDefault [] name options }) completed' = if toRawPLI complLoc == rawLoc then completed else CompletedPLI rawLoc complLoc:completed pure (p:ps, completed') (revNew, revCompleted) <- foldM addPackage ([], []) newPackages let (newSingles, newMultiples) = partitionEithers $ map sonToEither $ Map.toList $ Map.fromListWith (<>) $ map (second Single) (reverse revNew) unless (null newMultiples) $ throwIO $ DuplicatePackageNames source $ map (second (map (toRawPLI . spLocation))) newMultiples let new = Map.fromList newSingles allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) allPackages = flip Map.mapWithKey allPackages0 $ \name sp -> sp { spFlags = Map.findWithDefault (spFlags sp) name flags , spHidden = Map.findWithDefault (spHidden sp) name hiddens , spGhcOptions = Map.findWithDefault (spGhcOptions sp) name options } unused = AddPackagesConfig (drops `Set.difference` Map.keysSet old) (flags `Map.difference` allPackages) (hiddens `Map.difference` allPackages) (options `Map.difference` allPackages) pure (allPackages, reverse revCompleted, unused) -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- -- Returns a 'Left' value if provided an 'SLCompiler' constructor. Otherwise, -- returns a 'Right' value providing both the 'Snapshot' and a hash of the input -- configuration file. -- -- @since 0.1.0.0 loadRawSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => RawSnapshotLocation -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler loadRawSnapshotLayer rsl@(RSLUrl url blob) = handleAny (throwIO . InvalidSnapshot rsl) $ do bs <- loadFromURL url blob value <- Yaml.decodeThrow bs snapshot <- warningsParserHelperRaw rsl value Nothing pure $ Right (snapshot, CompletedSL rsl (SLUrl url (bsToBlobKey bs))) loadRawSnapshotLayer rsl@(RSLFilePath fp) = handleAny (throwIO . InvalidSnapshot rsl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp pure $ Right (snapshot, CompletedSL rsl (SLFilePath fp)) loadRawSnapshotLayer rsl@(RSLSynonym syn) = do loc <- snapshotLocation syn comp <- loadRawSnapshotLayer loc pure $ case comp of Left wc -> Left wc Right (l, CompletedSL _ n) -> Right (l, CompletedSL rsl n) -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- -- Returns a 'Left' value if provided an 'SLCompiler' constructor. Otherwise, -- returns a 'Right' value providing both the 'Snapshot' and a hash of the input -- configuration file. -- -- @since 0.1.0.0 loadSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => SnapshotLocation -> RIO env (Either WantedCompiler RawSnapshotLayer) loadSnapshotLayer (SLCompiler compiler) = pure $ Left compiler loadSnapshotLayer sl@(SLUrl url blob) = handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do bs <- loadFromURL url (Just blob) value <- Yaml.decodeThrow bs snapshot <- warningsParserHelper sl value Nothing pure $ Right snapshot loadSnapshotLayer sl@(SLFilePath fp) = handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp pure $ Right snapshot loadFromURL :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ url -> Maybe BlobKey -> RIO env ByteString loadFromURL url Nothing = do mcached <- withStorage $ loadURLBlob url case mcached of Just bs -> pure bs Nothing -> loadWithCheck url Nothing loadFromURL url (Just bkey) = do mcached <- withStorage $ loadBlob bkey case mcached of Just bs -> do logDebug "Loaded snapshot from Pantry database." pure bs Nothing -> loadUrlViaCasaOrWithCheck url bkey loadUrlViaCasaOrWithCheck :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ url -> BlobKey -> RIO env ByteString loadUrlViaCasaOrWithCheck url blobKey = do mblobFromCasa <- casaLookupKey blobKey case mblobFromCasa of Just blob -> do logDebug ("Loaded snapshot from Casa (" <> display blobKey <> ") for URL: " <> display url) pure blob Nothing -> loadWithCheck url (Just blobKey) loadWithCheck :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ url -> Maybe BlobKey -> RIO env ByteString loadWithCheck url mblobkey = do let (msha, msize) = case mblobkey of Nothing -> (Nothing, Nothing) Just (BlobKey sha size) -> (Just sha, Just size) (_, _, bss) <- httpSinkChecked url msha msize sinkList let bs = B.concat bss withStorage $ storeURLBlob url bs logDebug ("Loaded snapshot from third party: " <> display url) pure bs warningsParserHelperRaw :: HasLogFunc env => RawSnapshotLocation -> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer warningsParserHelperRaw rsl val mdir = case parseEither Yaml.parseJSON val of Left e -> throwIO $ Couldn'tParseSnapshot rsl e Right (WithJSONWarnings x ws) -> do unless (null ws) $ do logWarn $ "Warnings when parsing snapshot " <> display rsl for_ ws $ logWarn . display resolvePaths mdir x warningsParserHelper :: HasLogFunc env => SnapshotLocation -> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer warningsParserHelper sl val mdir = case parseEither Yaml.parseJSON val of Left e -> throwIO $ Couldn'tParseSnapshot (toRawSL sl) e Right (WithJSONWarnings x ws) -> do unless (null ws) $ do logWarn $ "Warnings when parsing snapshot " <> display sl for_ ws $ logWarn . display resolvePaths mdir x -- | Get the 'PackageName' of the package at the given location. -- -- @since 0.1.0.0 getPackageLocationName :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env PackageName getPackageLocationName = fmap pkgName . getRawPackageLocationIdent -- | Get the 'PackageIdentifier' of the package at the given location. -- -- @since 0.1.0.0 packageLocationIdent :: PackageLocationImmutable -> PackageIdentifier packageLocationIdent (PLIHackage ident _ _) = ident packageLocationIdent (PLIRepo _ pm) = pmIdent pm packageLocationIdent (PLIArchive _ pm) = pmIdent pm -- | Get version of the package at the given location. -- -- @since 0.1.0.0 packageLocationVersion :: PackageLocationImmutable -> Version packageLocationVersion (PLIHackage pident _ _) = pkgVersion pident packageLocationVersion (PLIRepo _ pm) = pkgVersion (pmIdent pm) packageLocationVersion (PLIArchive _ pm) = pkgVersion (pmIdent pm) -- | Get the 'PackageIdentifier' of the package at the given location. -- -- @since 0.1.0.0 getRawPackageLocationIdent :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env PackageIdentifier getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version getRawPackageLocationIdent (RPLIRepo _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version getRawPackageLocationIdent (RPLIArchive _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version getRawPackageLocationIdent rpli = packageIdent <$> loadPackageRaw rpli -- | Get the 'TreeKey' of the package at the given location. -- -- @since 0.1.0.0 getRawPackageLocationTreeKey :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env TreeKey getRawPackageLocationTreeKey pl = case getRawTreeKey pl of Just treeKey' -> pure treeKey' Nothing -> case pl of RPLIHackage pir _ -> getHackageTarballKey pir RPLIArchive archive pm -> getArchiveKey pl archive pm RPLIRepo repo pm -> getRepoKey repo pm -- | Get the 'TreeKey' of the package at the given location. -- -- @since 0.1.0.0 getPackageLocationTreeKey :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env TreeKey getPackageLocationTreeKey pl = pure $ getTreeKey pl getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey getRawTreeKey (RPLIHackage _ mtree) = mtree getRawTreeKey (RPLIArchive _ rpm) = rpmTreeKey rpm getRawTreeKey (RPLIRepo _ rpm) = rpmTreeKey rpm getTreeKey :: PackageLocationImmutable -> TreeKey getTreeKey (PLIHackage _ _ tree) = tree getTreeKey (PLIArchive _ pm) = pmTreeKey pm getTreeKey (PLIRepo _ pm) = pmTreeKey pm -- | Convenient data type that allows you to work with pantry more easily than -- using 'withPantryConfig' or 'withPantryConfig'' directly. Uses basically sane -- settings, like sharing a pantry directory with Stack. -- -- You can use 'runPantryApp' to use this. A simple example is: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > module Main (main) where -- > -- > -- From package Cabal-syntax -- > import Distribution.Types.Version ( mkVersion ) -- > -- From package pantry -- > import Pantry -- > ( CabalFileInfo (..), PackageIdentifierRevision (..), PantryApp -- > , RawPackageLocationImmutable (..), loadPackageRaw, runPantryApp -- > ) -- > -- From package rio -- > import RIO ( RIO, liftIO ) -- > -- > main :: IO () -- > main = runPantryApp myPantryApp -- > -- > myPantryApp :: RIO PantryApp () -- > myPantryApp = loadPackageRaw baseLocation >>= liftIO . print -- > where -- > baseVersion = mkVersion [4, 19, 0, 0] -- > basePkgId = PackageIdentifierRevision "base" baseVersion CFILatest -- > baseLocation = RPLIHackage basePkgId Nothing -- -- @since 0.1.0.0 data PantryApp = PantryApp { paSimpleApp :: !SimpleApp , paPantryConfig :: !PantryConfig , paUseColor :: !Bool , paTermWidth :: !Int , paStylesUpdate :: !StylesUpdate } simpleAppL :: Lens' PantryApp SimpleApp simpleAppL = lens paSimpleApp (\x y -> x { paSimpleApp = y }) -- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig' -- -- @since 0.1.0.0 hpackExecutableL :: Lens' PantryConfig HpackExecutable hpackExecutableL k pconfig = fmap (\hpExe -> pconfig { pcHpackExecutable = hpExe }) (k (pcHpackExecutable pconfig)) instance HasLogFunc PantryApp where logFuncL = simpleAppL.logFuncL instance HasPantryConfig PantryApp where pantryConfigL = lens paPantryConfig (\x y -> x { paPantryConfig = y }) instance HasProcessContext PantryApp where processContextL = simpleAppL.processContextL instance HasStylesUpdate PantryApp where stylesUpdateL = lens paStylesUpdate (\x y -> x { paStylesUpdate = y }) instance HasTerm PantryApp where useColorL = lens paUseColor (\x y -> x { paUseColor = y }) termWidthL = lens paTermWidth (\x y -> x { paTermWidth = y }) -- | Run some code against pantry using basic sane settings. -- -- For testing, see 'runPantryAppClean'. -- -- @since 0.1.0.0 runPantryApp :: MonadIO m => RIO PantryApp a -> m a runPantryApp = runPantryAppWith 8 defaultCasaRepoPrefix defaultCasaMaxPerRequest -- | Run some code against pantry using basic sane settings. -- -- For testing, see 'runPantryAppClean'. -- -- @since 0.1.1.1 runPantryAppWith :: MonadIO m => Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a runPantryAppWith maxConnCount casaRepoPrefix casaMaxPerRequest f = runSimpleApp $ do sa <- ask stack <- getAppUserDataDirectory "stack" root <- parseAbsDir $ stack FilePath. "pantry" withPantryConfig' root defaultPackageIndexConfig HpackBundled maxConnCount (Just (casaRepoPrefix, casaMaxPerRequest)) defaultSnapshotLocation $ \pc -> runRIO PantryApp { paSimpleApp = sa , paPantryConfig = pc , paTermWidth = 100 , paUseColor = True , paStylesUpdate = mempty } f -- | Like 'runPantryApp', but uses an empty pantry directory instead of sharing -- with Stack. Useful for testing. -- -- @since 0.1.0.0 runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a runPantryAppClean f = liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> runSimpleApp $ do sa <- ask root <- resolveDir' dir withPantryConfig' root defaultPackageIndexConfig HpackBundled 8 (Just (defaultCasaRepoPrefix, defaultCasaMaxPerRequest)) defaultSnapshotLocation $ \pc -> runRIO PantryApp { paSimpleApp = sa , paPantryConfig = pc , paTermWidth = 100 , paUseColor = True , paStylesUpdate = mempty } f -- | Load the global hints from GitHub. -- -- @since 0.1.0.0 loadGlobalHints :: (HasTerm env, HasPantryConfig env) => WantedCompiler -> RIO env (Maybe (Map PackageName Version)) loadGlobalHints wc = inner False where inner alreadyDownloaded = do dest <- getGlobalHintsFile req <- parseRequest "https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/global-hints.yaml" downloaded <- download req dest eres <- tryAny (inner2 dest) mres <- case eres of Left e -> Nothing <$ logError ( "Error: [S-912]\n" <> "Error when parsing global hints: " <> displayShow e ) Right x -> pure x case mres of Nothing | not alreadyDownloaded && not downloaded -> do logInfo $ "Could not find local global hints for " <> RIO.display wc <> ", forcing a redownload" x <- redownload req dest if x then inner True else do logInfo "Redownload didn't happen" pure Nothing _ -> pure mres inner2 dest = liftIO $ Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) <$> Yaml.decodeFileThrow (toFilePath dest) -- | Partition a map of global packages with its versions into a Set of replaced -- packages and its dependencies and a map of remaining (untouched) packages. -- -- @since 0.1.0.0 partitionReplacedDependencies :: Ord id => Map PackageName a -- ^ global packages -> (a -> PackageName) -- ^ package name getter -> (a -> id) -- ^ returns unique package id used for dependency pruning -> (a -> [id]) -- ^ returns unique package ids of direct package dependencies -> Set PackageName -- ^ overrides which global dependencies should get pruned -> (Map PackageName [PackageName], Map PackageName a) partitionReplacedDependencies globals getName getId getDeps overrides = flip execState (replaced, mempty) $ for (Map.toList globals) $ prunePackageWithDeps globals' getName getDeps where globals' = Map.fromList $ map (getId &&& id) (Map.elems globals) replaced = Map.map (const []) $ Map.restrictKeys globals overrides prunePackageWithDeps :: Ord id => Map id a -> (a -> PackageName) -> (a -> [id]) -> (PackageName, a) -> State (Map PackageName [PackageName], Map PackageName a) Bool prunePackageWithDeps pkgs getName getDeps (pname, a) = do (pruned, kept) <- get if Map.member pname pruned then pure True else if Map.member pname kept then pure False else do let deps = Map.elems $ Map.restrictKeys pkgs (Set.fromList $ getDeps a) prunedDeps <- forMaybeM deps $ \dep -> do let depName = getName dep isPruned <- prunePackageWithDeps pkgs getName getDeps (depName, dep) pure $ if isPruned then Just depName else Nothing if null prunedDeps then do modify' $ second (Map.insert pname a) else do modify' $ first (Map.insert pname prunedDeps) pure $ not (null prunedDeps) -- | Use a snapshot cache, which caches which modules are in which packages in a -- given snapshot. This is mostly intended for usage by Stack. -- -- @since 0.1.0.0 withSnapshotCache :: (HasPantryConfig env, HasLogFunc env) => SnapshotCacheHash -> RIO env (Map PackageName (Set ModuleName)) -> ((ModuleName -> RIO env [PackageName]) -> RIO env a) -> RIO env a withSnapshotCache hash getModuleMapping f = do mres <- withStorage $ getSnapshotCacheByHash hash cacheId <- case mres of Nothing -> do logWarn "Populating snapshot module name cache" packageModules <- getModuleMapping withStorage $ do scId <- getSnapshotCacheId hash storeSnapshotModuleCache scId packageModules pure scId Just scId -> pure scId f $ withStorage . loadExposedModulePackages cacheId -- | Add an s to the builder if n!=1. plural :: Int -> Utf8Builder -> Utf8Builder plural n text = display n <> " " <> text <> (if n == 1 then "" else "s") pantry-0.9.3.2/src/Pantry/SQLite.hs0000644000000000000000000001171514520750057015141 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Pantry.SQLite ( Storage (..) , initStorage ) where import Control.Concurrent.Companion ( Companion, onCompanionDone, withCompanion ) import Database.Persist.Sql ( runSqlConn ) import Database.Persist.Sql.Migration ( Migration, runMigrationSilent ) import Database.Persist.Sqlite ( extraPragmas, fkEnabled, mkSqliteConnectionInfo , walEnabled, withSqliteConnInfo ) import Pantry.Types ( PantryException (..), 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 -- ^ Database description, for lock messages. -> Migration -- ^ Initial migration. -> Path Abs File -- ^ SQLite database file. -> (Storage -> RIO env a) -- ^ What to do with the initialised 'Storage'. -> 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 pantry-0.9.3.2/src/Pantry/Internal/Stackage.hs0000644000000000000000000000243414454761646017310 0ustar0000000000000000-- | All types and functions exported from this module are for advanced usage -- only. They are needed for stackage-server integration with pantry and some -- are needed for stack testing. module Pantry.Internal.Stackage ( module X ) where import Pantry.Hackage as X ( HackageTarballResult (..), forceUpdateHackageIndex , getHackageTarball ) import Pantry.Storage as X ( BlobId, EntityField (..), HackageCabalId, Key (unBlobKey) , ModuleNameId, PackageName, PackageNameId, Tree (..) , TreeEntryId, TreeId, Unique (..), Version, VersionId , allBlobsCount, allBlobsSource, allHackageCabalCount , allHackageCabalRawPackageLocations, getBlobKey , getPackageNameById, getPackageNameId, getTreeForKey , getVersionId, loadBlobById, migrateAll, storeBlob , versionVersion ) import Pantry.Types as X ( ModuleNameP (..), PackageNameP (..), PantryConfig (..) , SafeFilePath, Storage (..), VersionP (..), mkSafeFilePath , packageTreeKey, unSafeFilePath ) pantry-0.9.3.2/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs0000644000000000000000000001406014520750057024672 0ustar0000000000000000-- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- Adapted from `hackage-security-http-client` to use our own -- `Pantry.HTTP` implementation module Hackage.Security.Client.Repository.HttpLib.HttpClient ( httpLib ) where import Control.Exception ( handle ) import Control.Monad ( void ) import Data.ByteString ( ByteString ) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.C8 import Hackage.Security.Client ( SomeRemoteError (..) ) import Hackage.Security.Client.Repository.HttpLib ( BodyReader, HttpLib (..), HttpRequestHeader (..) , HttpResponseHeader (..), HttpStatus (..) ) import Hackage.Security.Util.Checked ( Throws, handleChecked, throwChecked ) import Network.URI ( URI ) import qualified Pantry.HTTP as HTTP {------------------------------------------------------------------------------- Top-level API -------------------------------------------------------------------------------} -- | An 'HttpLib' value using the default global manager httpLib :: HttpLib httpLib = HttpLib { httpGet = get , httpGetRange = getRange } {------------------------------------------------------------------------------- Individual methods -------------------------------------------------------------------------------} get :: Throws SomeRemoteError => [HttpRequestHeader] -> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a get reqHeaders uri callback = wrapCustomEx $ do -- TODO: setUri fails under certain circumstances; in particular, when -- the URI contains URL auth. Not sure if this is a concern. request' <- HTTP.setUri HTTP.defaultRequest uri let request = setRequestHeaders reqHeaders request' checkHttpException $ HTTP.withResponse request $ \response -> do let br = wrapCustomEx $ HTTP.getResponseBody response callback (getResponseHeaders response) br getRange :: Throws SomeRemoteError => [HttpRequestHeader] -> URI -> (Int, Int) -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a getRange reqHeaders uri (from, to) callback = wrapCustomEx $ do request' <- HTTP.setUri HTTP.defaultRequest uri let request = setRange from to $ setRequestHeaders reqHeaders request' checkHttpException $ HTTP.withResponse request $ \response -> do let br = wrapCustomEx $ HTTP.getResponseBody response case () of () | HTTP.getResponseStatus response == HTTP.partialContent206 -> callback HttpStatus206PartialContent (getResponseHeaders response) br () | HTTP.getResponseStatus response == HTTP.ok200 -> callback HttpStatus200OK (getResponseHeaders response) br _otherwise -> throwChecked $ HTTP.HttpExceptionRequest request $ HTTP.StatusCodeException (void response) "" -- | Wrap custom exceptions -- -- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@ -- but it is currently disabled wrapCustomEx :: (Throws HTTP.HttpException => IO a) -> (Throws SomeRemoteError => IO a) wrapCustomEx = handleChecked (\(ex :: HTTP.HttpException) -> go ex) where go ex = throwChecked (SomeRemoteError ex) checkHttpException :: Throws HTTP.HttpException => IO a -> IO a checkHttpException = handle $ \(ex :: HTTP.HttpException) -> throwChecked ex {------------------------------------------------------------------------------- http-client auxiliary -------------------------------------------------------------------------------} hAcceptRanges :: HTTP.HeaderName hAcceptRanges = "Accept-Ranges" hAcceptEncoding :: HTTP.HeaderName hAcceptEncoding = "Accept-Encoding" setRange :: Int -> Int -> HTTP.Request -> HTTP.Request setRange from to = HTTP.addRequestHeader HTTP.hRange rangeHeader where -- Content-Range header uses inclusive rather than exclusive bounds -- See rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1) -- | Set request headers setRequestHeaders :: [HttpRequestHeader] -> HTTP.Request -> HTTP.Request setRequestHeaders opts = setRequestHeaders' (trOpt disallowCompressionByDefault opts) where setRequestHeaders' :: [HTTP.Header] -> HTTP.Request -> HTTP.Request setRequestHeaders' = foldr (\(name, val) f -> f . HTTP.setRequestHeader name [val]) id trOpt :: [(HTTP.HeaderName, [ByteString])] -> [HttpRequestHeader] -> [HTTP.Header] trOpt acc [] = map finalizeHeader acc trOpt acc (HttpRequestMaxAge0:os) = trOpt (insert HTTP.hCacheControl ["max-age=0"] acc) os trOpt acc (HttpRequestNoTransform:os) = trOpt (insert HTTP.hCacheControl ["no-transform"] acc) os -- disable content compression (potential security issue) disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])] disallowCompressionByDefault = [(hAcceptEncoding, [])] -- Some headers are comma-separated, others need multiple headers for -- multiple options. -- -- TODO: Right we we just comma-separate all of them. finalizeHeader :: (HTTP.HeaderName, [ByteString]) -> HTTP.Header finalizeHeader (name, strs) = (name, BS.intercalate ", " (reverse strs)) insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] insert _ _ [] = [] insert x y ((k, v):pairs) | x == k = (k, v ++ y) : insert x y pairs | otherwise = (k, v) : insert x y pairs -- | Extract the response headers getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader] getResponseHeaders response = [ HttpResponseAcceptRangesBytes | (hAcceptRanges, "bytes") `elem` headers ] where headers = HTTP.getResponseHeaders response pantry-0.9.3.2/src/Pantry/Archive.hs0000644000000000000000000005767014532676034015400 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -- | Logic for loading up trees from HTTPS archives. module Pantry.Archive ( getArchivePackage , getArchive , getArchiveKey , fetchArchivesRaw , fetchArchives , findCabalOrHpackFile ) where import qualified Codec.Archive.Zip as Zip import Conduit ( ConduitT, (.|), runConduit, sinkHandle, sinkList , sourceHandle, sourceLazy, withSourceFile ) import Data.Bits ( (.&.), shiftR ) import qualified Data.Conduit.Tar as Tar import Data.Conduit.Zlib ( ungzip ) import qualified Data.Digest.CRC32 as CRC32 import Distribution.PackageDescription ( package, packageDescription ) import qualified Hpack.Config as Hpack import Pantry.HPack ( hpackVersion ) import Pantry.HTTP ( httpSinkChecked ) import Pantry.Internal ( makeTarRelative, normalizeParents ) import qualified Pantry.SHA256 as SHA256 import Pantry.Storage ( BlobId, CachedTree (..), TreeId, hpackToCabal , loadArchiveCache, loadBlob, loadCabalBlobKey , loadCachedTree, loadPackageById, storeArchiveCache , storeBlob, storeHPack, storeTree, unCachedTree, withStorage ) import Pantry.Tree ( rawParseGPD ) import Pantry.Types ( Archive, ArchiveLocation (..), BlobKey, BuildFile (..) , FileSize (..), FileType (..), HasPantryConfig , Mismatch (..), Package (..), PackageCabal (..) , PackageIdentifier (..), PackageMetadata (..) , PantryException (..), PHpack (..), RawArchive (..) , RawPackageLocationImmutable (..), RawPackageMetadata (..) , ResolvedPath (..), SHA256, Tree (..), TreeEntry (..) , TreeKey, cabalFileName, hpackSafeFilePath, mkSafeFilePath , toRawArchive, toRawPM, unSafeFilePath ) import Path ( toFilePath ) import Path.IO ( doesFileExist ) import RIO import qualified RIO.ByteString.Lazy as BL import qualified RIO.List as List import qualified RIO.Map as Map import RIO.Process ( HasProcessContext ) import qualified RIO.Set as Set import qualified RIO.Text as T import qualified RIO.Text.Partial as T fetchArchivesRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(RawArchive, RawPackageMetadata)] -> RIO env () fetchArchivesRaw pairs = for_ pairs $ \(ra, rpm) -> getArchive (RPLIArchive ra rpm) ra rpm fetchArchives :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(Archive, PackageMetadata)] -> RIO env () fetchArchives pairs = -- TODO be more efficient, group together shared archives fetchArchivesRaw [(toRawArchive a, toRawPM pm) | (a, pm) <- pairs] getArchiveKey :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -- ^ for exceptions -> RawArchive -> RawPackageMetadata -> RIO env TreeKey getArchiveKey rpli archive rpm = packageTreeKey <$> getArchivePackage rpli archive rpm -- potential optimization thd4 :: (a, b, c, d) -> c thd4 (_, _, z, _) = z getArchivePackage :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) => RawPackageLocationImmutable -- ^ for exceptions -> RawArchive -> RawPackageMetadata -> RIO env Package getArchivePackage rpli archive rpm = thd4 <$> getArchive rpli archive rpm getArchive :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) => RawPackageLocationImmutable -- ^ for exceptions -> RawArchive -> RawPackageMetadata -> RIO env (SHA256, FileSize, Package, CachedTree) getArchive rpli archive rpm = do -- Check if the value is in the cache, and use it if possible mcached <- loadCache rpli archive -- Ensure that all of the blobs referenced exist in the cache -- See: https://github.com/commercialhaskell/pantry/issues/27 mtree <- case mcached of Nothing -> pure Nothing Just (_, _, pa) -> do etree <- withStorage $ loadCachedTree $ packageTree pa case etree of Left e -> do logDebug $ "getArchive of " <> displayShow rpli <> ": loadCachedTree failed: " <> displayShow e pure Nothing Right x -> pure $ Just x cached@(_, _, pa, _) <- case (mcached, mtree) of (Just (a, b, c), Just d) -> pure (a, b, c, d) -- Not in the archive. Load the archive. Completely ignore the -- PackageMetadata for now, we'll check that the Package info matches -- next. _ -> withArchiveLoc archive $ \fp sha size -> do (pa, tree) <- parseArchive rpli archive fp -- Storing in the cache exclusively uses information we have about the -- archive itself, not metadata from the user. storeCache archive sha size pa pure (sha, size, pa, tree) either throwIO (\_ -> pure cached) $ checkPackageMetadata rpli rpm pa storeCache :: forall env. (HasPantryConfig env, HasLogFunc env) => RawArchive -> SHA256 -> FileSize -> Package -> RIO env () storeCache archive sha size pa = case raLocation archive of ALUrl url -> withStorage $ storeArchiveCache url (raSubdir archive) sha size (packageTreeKey pa) ALFilePath _ -> pure () -- TODO cache local as well loadCache :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package)) loadCache rpli archive = case loc of ALFilePath _ -> pure Nothing -- TODO can we do something intelligent here? ALUrl url -> withStorage (loadArchiveCache url (raSubdir archive)) >>= loop where loc = raLocation archive msha = raHash archive msize = raSize archive loadFromCache :: TreeId -> RIO env (Maybe Package) loadFromCache tid = fmap Just $ withStorage $ loadPackageById rpli tid loop [] = pure Nothing loop ((sha, size, tid):rest) = case msha of Nothing -> do case msize of Just size' | size /= size' -> loop rest _ -> do case loc of ALUrl url -> do -- Only debug level, let lock files solve this logDebug $ "Using archive from " <> display url <> " without a specified cryptographic hash" logDebug $ "Cached hash is " <> display sha <> ", file size " <> display size ALFilePath _ -> pure () fmap (sha, size,) <$> loadFromCache tid Just sha' | sha == sha' -> case msize of Nothing -> do case loc of -- Only debug level, let lock files solve this ALUrl url -> logDebug $ "Archive from " <> display url <> " does not specify a size" ALFilePath _ -> pure () fmap (sha, size,) <$> loadFromCache tid Just size' | size == size' -> fmap (sha, size,) <$> loadFromCache tid | otherwise -> do -- This is an actual warning, since we have a concrete -- mismatch logWarn $ "Archive from " <> display loc <> " has a matching hash but mismatched size" logWarn "Please verify that your configuration provides \ \the correct size" loop rest | otherwise -> loop rest -- ensure name, version, etc are correct checkPackageMetadata :: RawPackageLocationImmutable -> RawPackageMetadata -> Package -> Either PantryException Package checkPackageMetadata pl pm pa = do let err = MismatchedPackageMetadata pl pm (Just (packageTreeKey pa)) (packageIdent pa) test :: Eq a => Maybe a -> a -> Bool test (Just x) y = x == y test Nothing _ = True tests = [ test (rpmTreeKey pm) (packageTreeKey pa) , test (rpmName pm) (pkgName $ packageIdent pa) , test (rpmVersion pm) (pkgVersion $ packageIdent pa) ] in if and tests then Right pa else Left err -- | Provide a local file with the contents of the archive, regardless of where -- it comes from. If not downloading, checks that the archive file exists. -- Performs SHA256 and file size validation. withArchiveLoc :: HasLogFunc env => RawArchive -> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a withArchiveLoc (RawArchive (ALFilePath resolved) msha msize _subdir) f = do let abs' = resolvedAbsolute resolved fp = toFilePath abs' archiveExists <- doesFileExist abs' unless archiveExists $ throwIO $ LocalNoArchiveFileFound abs' (sha, size) <- withBinaryFile fp ReadMode $ \h -> do size <- FileSize . fromIntegral <$> hFileSize h for_ msize $ \size' -> when (size /= size') $ throwIO $ LocalInvalidSize abs' Mismatch { mismatchExpected = size' , mismatchActual = size } sha <- runConduit (sourceHandle h .| SHA256.sinkHash) for_ msha $ \sha' -> when (sha /= sha') $ throwIO $ LocalInvalidSHA256 abs' Mismatch { mismatchExpected = sha' , mismatchActual = sha } pure (sha, size) f fp sha size withArchiveLoc (RawArchive (ALUrl url) msha msize _subdir) f = withSystemTempFile "archive" $ \fp hout -> do logDebug $ "Downloading archive from " <> display url (sha, size, ()) <- httpSinkChecked url msha msize (sinkHandle hout) hClose hout f fp sha size data ArchiveType = ATTarGz | ATTar | ATZip deriving (Enum, Bounded) instance Display ArchiveType where display ATTarGz = "GZIP-ed tar file" display ATTar = "Uncompressed tar file" display ATZip = "Zip file" data METype = METNormal | METExecutable | METLink !FilePath deriving Show data MetaEntry = MetaEntry { mePath :: !FilePath , meType :: !METype } deriving Show foldArchive :: (HasPantryConfig env, HasLogFunc env) => ArchiveLocation -- ^ for error reporting -> FilePath -> ArchiveType -> a -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a) -> RIO env a foldArchive loc fp ATTarGz accum f = withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar loc accum f foldArchive loc fp ATTar accum f = withSourceFile fp $ \src -> runConduit $ src .| foldTar loc accum f foldArchive loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do let go accum entry = do let normalizedRelPath = removeInitialDotSlash $ Zip.eRelativePath entry me = MetaEntry normalizedRelPath met met = fromMaybe METNormal $ do let modes = shiftR (Zip.eExternalFileAttributes entry) 16 guard $ Zip.eVersionMadeBy entry .&. 0xFF00 == 0x0300 guard $ modes /= 0 Just $ if (modes .&. 0o100) == 0 then METNormal else METExecutable lbs = Zip.fromEntry entry let crcExpected = Zip.eCRC32 entry crcActual = CRC32.crc32 lbs when (crcExpected /= crcActual) $ throwIO $ CRC32Mismatch loc (Zip.eRelativePath entry) Mismatch { mismatchExpected = crcExpected , mismatchActual = crcActual } runConduit $ sourceLazy lbs .| f accum me isDir entry = case reverse $ Zip.eRelativePath entry of '/':_ -> True _ -> False -- We're entering lazy I/O land thanks to zip-archive. lbs <- BL.hGetContents h foldM go accum0 (filter (not . isDir) $ Zip.zEntries $ Zip.toArchive lbs) foldTar :: (HasPantryConfig env, HasLogFunc env) => ArchiveLocation -- ^ for exceptions -> a -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a) -> ConduitT ByteString o (RIO env) a foldTar loc accum0 f = do ref <- newIORef accum0 Tar.untar $ toME >=> traverse_ (\me -> do accum <- readIORef ref accum' <- f accum me writeIORef ref $! accum') readIORef ref where toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry) toME fi = do let exc = InvalidTarFileType loc (Tar.getFileInfoPath fi) (Tar.fileType fi) mmet <- case Tar.fileType fi of Tar.FTSymbolicLink bs -> case decodeUtf8' bs of Left _ -> throwIO exc Right text -> pure $ Just $ METLink $ T.unpack text Tar.FTNormal -> pure $ Just $ if Tar.fileMode fi .&. 0o100 /= 0 then METExecutable else METNormal Tar.FTDirectory -> pure Nothing _ -> throwIO exc pure $ (\met -> MetaEntry { mePath = removeInitialDotSlash . Tar.getFileInfoPath $ fi , meType = met }) <$> mmet data SimpleEntry = SimpleEntry { seSource :: !FilePath , seType :: !FileType } deriving Show removeInitialDotSlash :: FilePath -> FilePath removeInitialDotSlash filename = fromMaybe filename $ List.stripPrefix "./" filename -- | Attempt to parse the contents of the given archive in the given subdir into -- a 'Tree'. This will not consult any caches. It will ensure that: -- -- * The cabal file exists -- -- * The cabal file can be parsed -- -- * The name inside the cabal file matches the name of the cabal file itself parseArchive :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RawArchive -> FilePath -- ^ file holding the archive -> RIO env (Package, CachedTree) parseArchive rpli archive fp = do let loc = raLocation archive archiveTypes :: [ArchiveType] archiveTypes = [minBound .. maxBound] getFiles :: [ArchiveType] -> RIO env (ArchiveType, Map FilePath MetaEntry) getFiles [] = throwIO $ UnknownArchiveType loc getFiles (at:ats) = do eres <- tryAny $ -- foldArchive normalises filepaths in archives that begin with ./ foldArchive loc fp at id $ \m me -> pure $ m . (me:) case eres of Left e -> do logDebug $ "parseArchive of " <> display at <> ": " <> displayShow e getFiles ats Right files -> pure (at, Map.fromList $ map (mePath &&& id) $ files []) (at, files) <- getFiles archiveTypes let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry) toSimple key me = case meType me of METNormal -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTNormal METExecutable -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTExecutable METLink relDest -> do case relDest of '/':_ -> Left $ concat [ "File located at " , show $ mePath me , " is a symbolic link to absolute path " , relDest ] _ -> Right () dest0 <- case makeTarRelative (mePath me) relDest of Left e -> Left $ concat [ "Error resolving relative path " , relDest , " from symlink at " , mePath me , ": " , e ] Right x -> Right x dest <- case normalizeParents dest0 of Left e -> Left $ concat [ "Invalid symbolic link from " , mePath me , " to " , relDest , ", tried parsing " , dest0 , ": " , e ] Right x -> Right x -- Check if it's a symlink to a file case Map.lookup dest files of Nothing -> -- Check if it's a symlink to a directory case findWithPrefix dest files of [] -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest ++ ".\n" ++ "This may indicate that the source is a git \ \archive which uses git-annex.\n" ++ "See https://github.com/commercialhaskell/stack/issues/4579 \ \for further information." pairs -> fmap fold $ for pairs $ \(suffix, me') -> toSimple (key ++ '/' : suffix) me' Just me' -> case meType me' of METNormal -> Right $ Map.singleton key $ SimpleEntry dest FTNormal METExecutable -> Right $ Map.singleton key $ SimpleEntry dest FTExecutable METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest case fold <$> Map.traverseWithKey toSimple files of Left e -> throwIO $ UnsupportedTarball loc $ T.pack e Right files1 -> do let files2 = stripCommonPrefix $ Map.toList files1 files3 = takeSubdir (raSubdir archive) files2 toSafe (fp', a) = case mkSafeFilePath fp' of Nothing -> Left $ "Not a safe file path: " ++ show fp' Just sfp -> Right (sfp, a) case traverse toSafe files3 of Left e -> throwIO $ UnsupportedTarball loc $ T.pack e Right safeFiles -> do let toSave = Set.fromList $ map (seSource . snd) safeFiles (blobs :: Map FilePath (BlobKey, BlobId)) <- foldArchive loc fp at mempty $ \m me -> if mePath me `Set.member` toSave then do bs <- mconcat <$> sinkList (blobId, blobKey) <- lift $ withStorage $ storeBlob bs pure $ Map.insert (mePath me) (blobKey, blobId) m else pure m tree :: CachedTree <- fmap (CachedTreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) -> case Map.lookup (removeInitialDotSlash . seSource $ se) blobs of Nothing -> error $ "Impossible: blob not found for: " ++ seSource se Just (blobKey, blobId) -> pure (sfp, (TreeEntry blobKey (seType se), blobId)) -- parse the cabal file and ensure it has the right name buildFile <- findCabalOrHpackFile rpli $ unCachedTree tree (buildFilePath, buildFileBlobKey, buildFileEntry) <- case buildFile of BFCabal fpath te@(TreeEntry key _) -> pure (fpath, key, te) BFHpack te@(TreeEntry key _) -> pure (hpackSafeFilePath, key, te) mbs <- withStorage $ loadBlob buildFileBlobKey bs <- case mbs of Nothing -> throwIO $ TreeReferencesMissingBlob rpli buildFilePath buildFileBlobKey Just bs -> pure bs cabalBs <- case buildFile of BFCabal _ _ -> pure bs BFHpack _ -> snd <$> hpackToCabal rpli (unCachedTree tree) (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBs let ident@(PackageIdentifier name _) = package $ packageDescription gpd case buildFile of BFCabal _ _ -> when (buildFilePath /= cabalFileName name) $ throwIO $ WrongCabalFileName rpli buildFilePath name _ -> pure () -- It's good! Store the tree, let's bounce (tid, treeKey') <- withStorage $ storeTree rpli ident tree buildFile packageCabal <- case buildFile of BFCabal _ _ -> pure $ PCCabalFile buildFileEntry BFHpack _ -> do cabalKey <- withStorage $ do hpackId <- storeHPack rpli tid loadCabalBlobKey hpackId hpackSoftwareVersion <- hpackVersion let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) pure $ PCHpack $ PHpack { phOriginal = buildFileEntry , phGenerated = cabalTreeEntry , phVersion = hpackSoftwareVersion } pure (Package { packageTreeKey = treeKey' , packageTree = unCachedTree tree , packageCabalEntry = packageCabal , packageIdent = ident }, tree) -- | Find all of the files in the Map with the given directory as a prefix. -- Directory is given without trailing slash. Returns the suffix after stripping -- the given prefix. findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)] findWithPrefix dir = mapMaybe go . Map.toList where prefix = dir ++ "/" go (x, y) = (, y) <$> List.stripPrefix prefix x findCabalOrHpackFile :: MonadThrow m => RawPackageLocationImmutable -- ^ for exceptions -> Tree -> m BuildFile findCabalOrHpackFile loc (TreeMap m) = do let isCabalFile (sfp, _) = let txt = unSafeFilePath sfp in not ("/" `T.isInfixOf` txt) && (".cabal" `T.isSuffixOf` txt) isHpackFile (sfp, _) = let txt = unSafeFilePath sfp in T.pack Hpack.packageConfig == txt isBFCabal (BFCabal _ _) = True isBFCabal _ = False sfpBuildFile (BFCabal sfp _) = sfp sfpBuildFile (BFHpack _) = hpackSafeFilePath toBuildFile xs@(sfp, te) = let cbFile = if isCabalFile xs then Just $ BFCabal sfp te else Nothing hpFile = if isHpackFile xs then Just $ BFHpack te else Nothing in cbFile <|> hpFile case mapMaybe toBuildFile $ Map.toList m of [] -> throwM $ TreeWithoutCabalFile loc [bfile] -> pure bfile xs -> case filter isBFCabal xs of [] -> throwM $ TreeWithoutCabalFile loc [bfile] -> pure bfile xs' -> throwM $ TreeWithMultipleCabalFiles loc $ map sfpBuildFile xs' -- | If all files have a shared prefix, strip it off stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)] stripCommonPrefix [] = [] stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do let firstDir = takeWhile (/= '/') firstFP guard $ not $ null firstDir let strip (fp, a) = (, a) <$> List.stripPrefix (firstDir ++ "/") fp stripCommonPrefix <$> traverse strip pairs -- | Take us down to the specified subdirectory takeSubdir :: Text -- ^ subdir -> [(FilePath, a)] -- ^ files after stripping common prefix -> [(Text, a)] takeSubdir subdir = mapMaybe $ \(fp, a) -> do stripped <- List.stripPrefix subdirs $ splitDirs $ T.pack fp Just (T.intercalate "/" stripped, a) where splitDirs = List.dropWhile (== ".") . filter (/= "") . T.splitOn "/" subdirs = splitDirs subdir pantry-0.9.3.2/src/Pantry/HTTP.hs0000644000000000000000000000665314520750057014564 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.HTTP ( module Export , withResponse , httpSink , httpSinkChecked ) where import Conduit ( ConduitT, ZipSink (..), await, getZipSink ) import Network.HTTP.Client as Export ( BodyReader, HttpExceptionContent (StatusCodeException) , parseRequest, parseUrlThrow ) import qualified Network.HTTP.Client as HTTP ( withResponse ) import Network.HTTP.Client.Internal as Export ( setUri ) import Network.HTTP.Client.TLS ( getGlobalManager ) import Network.HTTP.Simple as Export ( HttpException (..), Request, Response, addRequestHeader , defaultRequest, getResponseBody, getResponseHeaders , getResponseStatus, setRequestHeader ) import qualified Network.HTTP.Simple as HTTP hiding ( withResponse ) import Network.HTTP.Types as Export ( Header, HeaderName, Status, hCacheControl, hRange, ok200 , partialContent206, statusCode ) import qualified Pantry.SHA256 as SHA256 import Pantry.Types ( FileSize (..), Mismatch (..), PantryException (..), SHA256 ) import RIO import qualified RIO.ByteString as B import qualified RIO.Text as T setUserAgent :: Request -> Request setUserAgent = setRequestHeader "User-Agent" ["Haskell pantry package"] withResponse :: MonadUnliftIO m => HTTP.Request -> (Response BodyReader -> m a) -> m a withResponse req inner = withRunInIO $ \run -> do manager <- getGlobalManager HTTP.withResponse (setUserAgent req) manager (run . inner) httpSink :: MonadUnliftIO m => Request -> (Response () -> ConduitT ByteString Void m a) -> m a httpSink req = HTTP.httpSink (setUserAgent req) httpSinkChecked :: MonadUnliftIO m => Text -> Maybe SHA256 -> Maybe FileSize -> ConduitT ByteString Void m a -> m (SHA256, FileSize, a) httpSinkChecked url msha msize sink = do req <- liftIO $ parseUrlThrow $ T.unpack url httpSink req $ const $ getZipSink $ (,,) <$> ZipSink (checkSha msha) <*> ZipSink (checkSize msize) <*> ZipSink sink where checkSha mexpected = do actual <- SHA256.sinkHash for_ mexpected $ \expected -> unless (actual == expected) $ throwIO $ DownloadInvalidSHA256 url Mismatch { mismatchExpected = expected , mismatchActual = actual } pure actual checkSize mexpected = loop 0 where loop accum = do mbs <- await case mbs of Nothing -> case mexpected of Just (FileSize expected) | expected /= accum -> throwIO $ DownloadInvalidSize url Mismatch { mismatchExpected = FileSize expected , mismatchActual = FileSize accum } _ -> pure (FileSize accum) Just bs -> do let accum' = accum + fromIntegral (B.length bs) case mexpected of Just (FileSize expected) | accum' > expected -> throwIO $ DownloadTooLarge url Mismatch { mismatchExpected = FileSize expected , mismatchActual = FileSize accum' } _ -> loop accum' pantry-0.9.3.2/src/Pantry/Hackage.hs0000644000000000000000000006751614520750057015335 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Pantry.Hackage ( updateHackageIndex , forceUpdateHackageIndex , DidUpdateOccur (..) , RequireHackageIndex (..) , hackageIndexTarballL , getHackageTarball , getHackageTarballKey , getHackageCabalFile , getHackagePackageVersions , getHackagePackageVersionRevisions , getHackageTypoCorrections , UsePreferredVersions (..) , HackageTarballResult(..) ) where import Conduit ( ZipSink (..), (.|), getZipSink, runConduit, sinkLazy , sinkList, sourceHandle, takeC, takeCE ) import Data.Aeson ( FromJSON (..), Value (..), (.:), eitherDecode' , withObject ) import Data.Conduit.Tar ( FileInfo (..), FileType (..), untar ) import qualified Data.List.NonEmpty as NE import Data.Text.Metrics (damerauLevenshtein) import Data.Text.Unsafe ( unsafeTail ) import Data.Time ( getCurrentTime ) import Database.Persist.Sql ( SqlBackend ) import Distribution.PackageDescription ( GenericPackageDescription ) import qualified Distribution.PackageDescription as Cabal import qualified Distribution.Text import Distribution.Types.Version (versionNumbers) import Distribution.Types.VersionRange (withinRange) import qualified Hackage.Security.Client as HS import qualified Hackage.Security.Client.Repository.Cache as HS import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS import qualified Hackage.Security.Client.Repository.Remote as HS import qualified Hackage.Security.Util.Path as HS import qualified Hackage.Security.Util.Pretty as HS import Network.URI ( parseURI ) import Pantry.Archive ( getArchive ) import Pantry.Casa ( casaLookupKey ) import qualified Pantry.SHA256 as SHA256 import Pantry.Storage ( CachedTree (..), TreeId, BlobId, clearHackageRevisions , countHackageCabals, getBlobKey, loadBlobById, loadBlobBySHA , loadHackagePackageVersion, loadHackagePackageVersions , loadHackageTarballInfo, loadHackageTree, loadHackageTreeKey , loadLatestCacheUpdate, loadPreferredVersion , sinkHackagePackageNames, storeBlob, storeCacheUpdate , storeHackageRevision, storeHackageTarballInfo , storeHackageTree, storePreferredVersion, storeTree , unCachedTree, withStorage ) import Pantry.Tree ( rawParseGPD ) import Pantry.Types ( ArchiveLocation (..), BlobKey (..), BuildFile (..) , CabalFileInfo (..), FileSize (..), FuzzyResults (..) , HackageSecurityConfig (..), HasPantryConfig (..) , Mismatch (..), Package (..), PackageCabal (..) , PackageIdentifier (..), PackageIdentifierRevision (..) , PackageIndexConfig (..), PackageName, PantryConfig (..) , PantryException (..), RawArchive (..) , RawPackageLocationImmutable (..), RawPackageMetadata (..) , Revision, SHA256, Storage (..), TreeEntry (..), TreeKey , Version, cabalFileName, packageNameString, parsePackageName , unSafeFilePath ) import Path ( Abs, Dir, File, Path, Rel, (), parseRelDir, parseRelFile , toFilePath ) import RIO import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import qualified RIO.Map as Map import RIO.Process ( HasProcessContext ) import qualified RIO.Text as T #if !MIN_VERSION_rio(0,1,16) -- Now provided by RIO from the rio package. Resolvers before lts-15.16 -- (GHC 8.8.3) had rio < 0.1.16. import System.IO ( SeekMode (..) ) #endif hackageRelDir :: Path Rel Dir hackageRelDir = either impureThrow id $ parseRelDir "hackage" hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir) hackageDirL = pantryConfigL.to (( hackageRelDir) . pcRootDir) indexRelFile :: Path Rel File indexRelFile = either impureThrow id $ parseRelFile "00-index.tar" -- | Where does pantry download its 01-index.tar file from Hackage? -- -- @since 0.1.0.0 hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File) hackageIndexTarballL = hackageDirL.to ( indexRelFile) -- | Did an update occur when running 'updateHackageIndex'? -- -- @since 0.1.0.0 data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred -- | Information returned by `getHackageTarball` -- -- @since 0.1.0.0 data HackageTarballResult = HackageTarballResult { htrPackage :: !Package -- ^ Package that was loaded from Hackage tarball , htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId)) -- ^ This information is only available whenever package was just loaded -- into pantry. } -- | Download the most recent 01-index.tar file from Hackage and update the -- database tables. -- -- This function will only perform an update once per 'PantryConfig' for user -- sanity. See the return value to find out if it happened. -- -- @since 0.1.0.0 updateHackageIndex :: (HasPantryConfig env, HasLogFunc env) => Maybe Utf8Builder -- ^ reason for updating, if any -> RIO env DidUpdateOccur updateHackageIndex = updateHackageIndexInternal False -- | Same as `updateHackageIndex`, but force the database update even if hackage -- security tells that there is no change. This can be useful in order to make -- sure the database is in sync with the locally downloaded tarball -- -- @since 0.1.0.0 forceUpdateHackageIndex :: (HasPantryConfig env, HasLogFunc env) => Maybe Utf8Builder -> RIO env DidUpdateOccur forceUpdateHackageIndex = updateHackageIndexInternal True updateHackageIndexInternal :: (HasPantryConfig env, HasLogFunc env) => Bool -- ^ Force the database update. -> Maybe Utf8Builder -- ^ reason for updating, if any -> RIO env DidUpdateOccur updateHackageIndexInternal forceUpdate mreason = do storage <- view $ pantryConfigL.to pcStorage gateUpdate $ withWriteLock_ storage $ do for_ mreason logInfo pc <- view pantryConfigL let PackageIndexConfig url (HackageSecurityConfig keyIds threshold ignoreExpiry) = pcPackageIndex pc root <- view hackageDirL tarball <- view hackageIndexTarballL baseURI <- case parseURI $ T.unpack url of Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url Just x -> pure x run <- askRunInIO let logTUF = run . logInfo . fromString . HS.pretty withRepo = HS.withRepository HS.httpLib [baseURI] HS.defaultRepoOpts HS.Cache { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root , HS.cacheLayout = HS.cabalCacheLayout } HS.hackageRepoLayout HS.hackageIndexLayout logTUF didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do needBootstrap <- HS.requiresBootstrap repo when needBootstrap $ do HS.bootstrap repo (map (HS.KeyId . T.unpack) keyIds) (HS.KeyThreshold $ fromIntegral threshold) maybeNow <- if ignoreExpiry then pure Nothing else Just <$> getCurrentTime HS.checkForUpdates repo maybeNow case didUpdate of _ | forceUpdate -> do logInfo "Forced package update is initialized" updateCache tarball HS.NoUpdates -> do x <- needsCacheUpdate tarball if x then do logInfo "No package index update available, but didn't update cache last time, running now" updateCache tarball else logInfo "No package index update available and cache up to date" HS.HasUpdates -> do logInfo "Updated package index downloaded" updateCache tarball logStickyDone "Package index cache populated" where -- The size of the new index tarball, ignoring the required (by the tar spec) -- 1024 null bytes at the end, which will be mutated in the future by other -- updates. getTarballSize :: MonadIO m => Handle -> m Word getTarballSize h = fromIntegral . max 0 . subtract 1024 <$> hFileSize h -- Check if the size of the tarball on the disk matches the value in -- CacheUpdate. If not, we need to perform a cache update, even if we didn't -- download any new information. This can be caused by canceling an -- updateCache call. needsCacheUpdate tarball = do mres <- withStorage loadLatestCacheUpdate case mres of Nothing -> pure True Just (FileSize cachedSize, _sha256) -> do actualSize <- withBinaryFile (toFilePath tarball) ReadMode getTarballSize pure $ cachedSize /= actualSize -- This is the one action in the Pantry codebase known to hold a write lock on -- the database for an extended period of time. To avoid failures due to -- SQLite locks failing, we take our own lock outside of SQLite for this -- action. -- -- See https://github.com/commercialhaskell/stack/issues/4471 updateCache tarball = withStorage $ do -- Alright, here's the story. In theory, we only ever append to a tarball. -- Therefore, we can store the last place we populated our cache from, and -- fast forward to that point. But there are two issues with that: -- -- 1. Hackage may rebase, in which case we need to recalculate everything -- from the beginning. Unfortunately, hackage-security doesn't let us know -- when that happens. -- -- 2. Some paranoia about files on the filesystem getting modified out from -- under us. -- -- Therefore, we store both the last read-to index, _and_ the SHA256 of all -- of the contents until that point. When updating the cache, we calculate -- the new SHA256 of the whole file, and the SHA256 of the previous read-to -- point. If the old hashes match, we can do an efficient fast forward. -- Otherwise, we clear the old cache and repopulate. minfo <- loadLatestCacheUpdate (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" newSize <- getTarballSize h let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash case minfo of Nothing -> do logInfo "No old cache found, populating cache from scratch" newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize pure (0, newHash, newSize) Just (FileSize oldSize, oldHash) -> do -- oldSize and oldHash come from the database, and tell -- us what we cached already. Compare against -- oldHashCheck, which assuming the tarball has not been -- rebased will be the same as oldHash. At the same -- time, calculate newHash, which is the hash of the new -- content as well. (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) <$> ZipSink (sinkSHA256 oldSize) <*> ZipSink (sinkSHA256 newSize) ) offset <- if oldHash == oldHashCheck then oldSize <$ logInfo "Updating preexisting cache, should be quick" else 0 <$ do logWarn $ mconcat [ "Package index change detected, that's pretty unusual: " , "\n Old size: " <> display oldSize , "\n Old hash (orig) : " <> display oldHash , "\n New hash (check): " <> display oldHashCheck , "\n Forcing a recache" ] pure (offset, newHash, newSize) lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash when (offset == 0) clearHackageRevisions populateCache tarball (fromIntegral offset) `onException` lift (logStickyDone "Failed populating package index cache") storeCacheUpdate (FileSize newSize) newHash gateUpdate inner = do pc <- view pantryConfigL join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ if toUpdate then (False, UpdateOccurred <$ inner) else (False, pure NoUpdateOccurred) -- | Populate the SQLite tables with Hackage index information. populateCache :: (HasPantryConfig env, HasLogFunc env) => Path Abs File -- ^ tarball -> Integer -- ^ where to start processing from -> ReaderT SqlBackend (RIO env) () populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do lift $ logInfo "Populating package index cache ..." counter <- newIORef (0 :: Int) hSeek h AbsoluteSeek offset runConduit $ sourceHandle h .| untar (perFile counter) where perFile counter fi | FTNormal <- fileType fi , Right path <- decodeUtf8' $ filePath fi , Just (name, version, filename) <- parseNameVersionSuffix path = if | filename == "package.json" -> sinkLazy >>= lift . addJSON name version | filename == unSafeFilePath (cabalFileName name) -> do sinkLazy >>= (lift . addCabal name version) . BL.toStrict count <- readIORef counter let count' = count + 1 writeIORef counter count' when (count' `mod` 400 == 0) $ lift $ lift $ logSticky $ "Processed " <> display count' <> " cabal files" | otherwise -> pure () | FTNormal <- fileType fi , Right path <- decodeUtf8' $ filePath fi , (nameT, "/preferred-versions") <- T.break (== '/') path , Just name <- parsePackageName $ T.unpack nameT = do lbs <- sinkLazy case decodeUtf8' $ BL.toStrict lbs of Left _ -> pure () -- maybe warning Right p -> lift $ storePreferredVersion name p | otherwise = pure () addJSON name version lbs = case eitherDecode' lbs of Left e -> lift $ logError $ "Error: [S-563]\n" <> "Error processing Hackage security metadata for " <> fromString (Distribution.Text.display name) <> "-" <> fromString (Distribution.Text.display version) <> ": " <> fromString e Right (PackageDownload sha size) -> storeHackageTarballInfo name version sha $ FileSize size addCabal name version bs = do (blobTableId, _blobKey) <- storeBlob bs storeHackageRevision name version blobTableId breakSlash x | T.null z = Nothing | otherwise = Just (y, unsafeTail z) where (y, z) = T.break (== '/') x parseNameVersionSuffix t1 = do (name, t2) <- breakSlash t1 (version, filename) <- breakSlash t2 name' <- Distribution.Text.simpleParse $ T.unpack name version' <- Distribution.Text.simpleParse $ T.unpack version Just (name', version', filename) -- | Package download info from Hackage data PackageDownload = PackageDownload !SHA256 !Word instance FromJSON PackageDownload where parseJSON = withObject "PackageDownload" $ \o1 -> do o2 <- o1 .: "signed" Object o3 <- o2 .: "targets" Object o4:_ <- pure $ toList o3 len <- o4 .: "length" hashes <- o4 .: "hashes" sha256' <- hashes .: "sha256" sha256 <- case SHA256.fromHexText sha256' of Left e -> fail $ "Invalid sha256: " ++ show e Right x -> pure x pure $ PackageDownload sha256 len getHackageCabalFile :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision -> RIO env ByteString getHackageCabalFile pir@(PackageIdentifierRevision _ _ cfi) = do bid <- resolveCabalFileInfo pir bs <- withStorage $ loadBlobById bid case cfi of CFIHash sha msize -> do let sizeMismatch = case msize of Nothing -> False Just size -> FileSize (fromIntegral (B.length bs)) /= size shaMismatch = sha /= SHA256.hashBytes bs when (sizeMismatch || shaMismatch) $ error $ "getHackageCabalFile: size or SHA mismatch for " ++ show (pir, bs) _ -> pure () pure bs resolveCabalFileInfo :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision -> RIO env BlobId resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do mres <- inner case mres of Just res -> pure res Nothing -> do updated <- updateHackageIndex $ Just $ "Cabal file info not found for " <> display pir <> ", updating" mres' <- case updated of UpdateOccurred -> inner NoUpdateOccurred -> pure Nothing case mres' of Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir Just res -> pure res where inner = case cfi of CFIHash sha msize -> loadOrDownloadBlobBySHA pir sha msize CFIRevision rev -> fmap fst . Map.lookup rev <$> withStorage (loadHackagePackageVersion name ver) CFILatest -> fmap (fst . fst) . Map.maxView <$> withStorage (loadHackagePackageVersion name ver) -- | Load or download a blob by its SHA. loadOrDownloadBlobBySHA :: (Display a, HasPantryConfig env, HasLogFunc env) => a -> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId) loadOrDownloadBlobBySHA label sha256 msize = do mresult <- byDB case mresult of Nothing -> do case msize of Nothing -> do pure Nothing Just size -> do mblob <- casaLookupKey (BlobKey sha256 size) case mblob of Nothing -> do pure Nothing Just {} -> do result <- byDB case result of Just blobId -> do logDebug ("Pulled blob from Casa for " <> display label) pure (Just blobId) Nothing -> do logWarn ("Bug? Blob pulled from Casa not in database for " <> display label) pure Nothing Just blobId -> do logDebug ("Got blob from Pantry database for " <> display label) pure (Just blobId) where byDB = withStorage $ loadBlobBySHA sha256 -- | Given package identifier and package caches, return list of packages with -- the same name and the same two first version number components found in the -- caches. fuzzyLookupCandidates :: (HasPantryConfig env, HasLogFunc env) => PackageName -> Version -> RIO env FuzzyResults fuzzyLookupCandidates name ver0 = do m <- getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions name if Map.null m then FRNameNotFound <$> getHackageTypoCorrections name else case Map.lookup ver0 m of Nothing -> do let withVers vers = pure $ FRVersionNotFound $ flip NE.map vers $ \(ver, revs) -> case Map.maxView revs of Nothing -> error "fuzzyLookupCandidates: no revisions" Just (BlobKey sha size, _) -> PackageIdentifierRevision name ver (CFIHash sha (Just size)) case NE.nonEmpty $ filter (sameMajor . fst) $ Map.toList m of Just vers -> withVers vers Nothing -> case NE.nonEmpty $ Map.toList m of Nothing -> error "fuzzyLookupCandidates: no versions" Just vers -> withVers vers Just revisions -> let pirs = map (\(BlobKey sha size) -> PackageIdentifierRevision name ver0 (CFIHash sha (Just size))) (Map.elems revisions) in case NE.nonEmpty pirs of Nothing -> error "fuzzyLookupCandidates: no revisions" Just pirs' -> pure $ FRRevisionNotFound pirs' where sameMajor v = toMajorVersion v == toMajorVersion ver0 toMajorVersion :: Version -> [Int] toMajorVersion v = case versionNumbers v of [] -> [0, 0] [a] -> [a, 0] a:b:_ -> [a, b] -- | Try to come up with typo corrections for given package identifier using -- Hackage package names. This can provide more user-friendly information in -- error messages. -- -- @since 0.1.0.0 getHackageTypoCorrections :: (HasPantryConfig env, HasLogFunc env) => PackageName -> RIO env [PackageName] getHackageTypoCorrections name1 = withStorage $ sinkHackagePackageNames (\name2 -> name1 `distance` name2 < 4) (takeC 10 .| sinkList) where distance = damerauLevenshtein `on` (T.pack . packageNameString) -- | Should we pay attention to Hackage's preferred versions? -- -- @since 0.1.0.0 data UsePreferredVersions = UsePreferredVersions | IgnorePreferredVersions deriving Show -- | Require that the Hackage index is populated. -- -- @since 0.1.0.0 data RequireHackageIndex = YesRequireHackageIndex -- ^ If there is nothing in the Hackage index, then perform an update | NoRequireHackageIndex -- ^ Do not perform an update deriving Show initializeIndex :: (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> RIO env () initializeIndex NoRequireHackageIndex = pure () initializeIndex YesRequireHackageIndex = do cabalCount <- withStorage countHackageCabals when (cabalCount == 0) $ void $ updateHackageIndex $ Just "No information from Hackage index, updating" -- | Returns the versions of the package available on Hackage. -- -- @since 0.1.0.0 getHackagePackageVersions :: (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> UsePreferredVersions -> PackageName -- ^ package name -> RIO env (Map Version (Map Revision BlobKey)) getHackagePackageVersions req usePreferred name = do initializeIndex req withStorage $ do mpreferred <- case usePreferred of UsePreferredVersions -> loadPreferredVersion name IgnorePreferredVersions -> pure Nothing let predicate :: Version -> Map Revision BlobKey -> Bool predicate = fromMaybe (\_ _ -> True) $ do preferredT1 <- mpreferred preferredT2 <- T.stripPrefix (T.pack $ packageNameString name) preferredT1 vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 Just $ \v _ -> withinRange v vr Map.filterWithKey predicate <$> loadHackagePackageVersions name -- | Returns the versions of the package available on Hackage. -- -- @since 0.1.0.0 getHackagePackageVersionRevisions :: (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> PackageName -- ^ package name -> Version -- ^ package version -> RIO env (Map Revision BlobKey) getHackagePackageVersionRevisions req name version = do initializeIndex req withStorage $ Map.map snd <$> loadHackagePackageVersion name version withCachedTree :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> PackageName -> Version -> BlobId -- ^ cabal file contents -> RIO env HackageTarballResult -> RIO env HackageTarballResult withCachedTree rpli name ver bid inner = do mres <- withStorage $ loadHackageTree rpli name ver bid case mres of Just package -> pure $ HackageTarballResult package Nothing Nothing -> do htr <- inner withStorage $ storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr pure htr getHackageTarballKey :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageIdentifierRevision -> RIO env TreeKey getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do mres <- withStorage $ loadHackageTreeKey name ver sha case mres of Nothing -> packageTreeKey . htrPackage <$> getHackageTarball pir Nothing Just key -> pure key getHackageTarballKey pir = packageTreeKey . htrPackage <$> getHackageTarball pir Nothing getHackageTarball :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageIdentifierRevision -> Maybe TreeKey -> RIO env HackageTarballResult getHackageTarball pir mtreeKey = do let PackageIdentifierRevision name ver _cfi = pir cabalFile <- resolveCabalFileInfo pir let rpli = RPLIHackage pir mtreeKey withCachedTree rpli name ver cabalFile $ do cabalFileKey <- withStorage $ getBlobKey cabalFile mpair <- withStorage $ loadHackageTarballInfo name ver (sha, size) <- case mpair of Just pair -> pure pair Nothing -> do let exc = NoHackageCryptographicHash $ PackageIdentifier name ver updated <- updateHackageIndex $ Just $ display exc <> ", updating" mpair2 <- case updated of UpdateOccurred -> withStorage $ loadHackageTarballInfo name ver NoUpdateOccurred -> pure Nothing case mpair2 of Nothing -> throwIO exc Just pair2 -> pure pair2 pc <- view pantryConfigL let urlPrefix = picDownloadPrefix $ pcPackageIndex pc url = mconcat [ urlPrefix , "package/" , T.pack $ Distribution.Text.display name , "-" , T.pack $ Distribution.Text.display ver , ".tar.gz" ] (_, _, package, cachedTree) <- getArchive rpli RawArchive { raLocation = ALUrl url , raHash = Just sha , raSize = Just size , raSubdir = T.empty -- no subdirs on Hackage } RawPackageMetadata { rpmName = Just name , rpmVersion = Just ver , rpmTreeKey = Nothing -- with a revision cabal file will differ -- giving a different tree } case cachedTree of CachedTreeMap m -> do let ft = case packageCabalEntry package of PCCabalFile (TreeEntry _ ft') -> ft' _ -> error "Impossible: Hackage does not support hpack" cabalEntry = TreeEntry cabalFileKey ft (cabalBS, cabalBlobId) <- withStorage $ do let BlobKey sha' _ = cabalFileKey mcabalBS <- loadBlobBySHA sha' case mcabalBS of Nothing -> error $ "Invariant violated, cabal file key: " ++ show cabalFileKey Just bid -> (, bid) <$> loadBlobById bid let tree' = CachedTreeMap $ Map.insert (cabalFileName name) (cabalEntry, cabalBlobId) m ident = PackageIdentifier name ver (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS let gpdIdent = Cabal.package $ Cabal.packageDescription gpd when (ident /= gpdIdent) $ throwIO $ MismatchedCabalFileForHackage pir Mismatch {mismatchExpected = ident, mismatchActual = gpdIdent} (tid, treeKey') <- withStorage $ storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) pure HackageTarballResult { htrPackage = Package { packageTreeKey = treeKey' , packageTree = unCachedTree tree' , packageIdent = ident , packageCabalEntry = PCCabalFile cabalEntry } , htrFreshPackageInfo = Just (gpd, tid) } pantry-0.9.3.2/src/Pantry/Repo.hs0000644000000000000000000003255214566666623014726 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Pantry.Repo ( fetchReposRaw , fetchRepos , getRepo , getRepoKey , createRepoArchive , withRepoArchive , withRepo ) where import Database.Persist.Class.PersistEntity ( Entity (..) ) import Pantry.Archive ( getArchivePackage ) import Pantry.Storage ( getTreeForKey, loadPackageById, loadRepoCache , storeRepoCache, withStorage ) import Pantry.Types ( AggregateRepo (..), ArchiveLocation (..), HasPantryConfig , Package (..), PackageMetadata (..), PantryException (..) , RawArchive (..), RawPackageLocationImmutable (..) , RawPackageMetadata (..), RelFilePath (..), Repo (..) , RepoType (..), ResolvedPath (..), SimpleRepo (..) , TreeKey (..), arToSimpleRepo, rToSimpleRepo , toAggregateRepos, toRawPM ) import Path.IO ( resolveFile' ) import RIO import RIO.ByteString ( isInfixOf ) import RIO.ByteString.Lazy ( toStrict ) import RIO.Directory ( doesDirectoryExist ) import RIO.FilePath ( () ) import qualified RIO.Map as Map import RIO.Process ( ExitCodeException (..), HasProcessContext, proc , readProcess, readProcess_, withModifyEnvVars , withWorkingDir ) import qualified RIO.Text as T #if MIN_VERSION_ansi_terminal(1, 0, 2) import System.Console.ANSI ( hNowSupportsANSI ) #else import System.Console.ANSI ( hSupportsANSIWithoutEmulation ) #endif import System.IsWindows ( osIsWindows ) data TarType = Gnu | Bsd getGitTarType :: (HasProcessContext env, HasLogFunc env) => RIO env TarType getGitTarType = if osIsWindows then do (_, stdoutBS, _) <- proc "git" ["--version"] readProcess let bs = toStrict stdoutBS -- If using Git for Windows, then assume that the tar type within -- `git submodule foreach ` is the Git-supplied\MSYS2-supplied -- GNU tar if "windows" `isInfixOf` bs then pure Gnu else getTarType else getTarType getTarType :: (HasProcessContext env, HasLogFunc env) => RIO env TarType getTarType = do (_, stdoutBS, _) <- proc "tar" ["--version"] readProcess let bs = toStrict stdoutBS pure $ if "GNU" `isInfixOf` bs then Gnu else Bsd -- | Like 'fetchRepos', except with 'RawPackageMetadata' instead of -- 'PackageMetadata'. -- -- @since 0.5.3 fetchReposRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(Repo, RawPackageMetadata)] -> RIO env () fetchReposRaw pairs = do let repos = toAggregateRepos pairs logDebug (displayShow repos) for_ repos getRepos -- | Fetch the given repositories at once and populate the pantry database. -- -- @since 0.5.3 fetchRepos :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(Repo, PackageMetadata)] -> RIO env () fetchRepos pairs = do -- TODO be more efficient, group together shared archives fetchReposRaw $ map (second toRawPM) pairs getRepoKey :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageMetadata -> RIO env TreeKey getRepoKey repo rpm = packageTreeKey <$> getRepo repo rpm -- potential optimization getRepo :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageMetadata -> RIO env Package getRepo repo pm = do withCache $ getRepo' repo pm where withCache :: RIO env Package -> RIO env Package withCache inner = do mtid <- withStorage (loadRepoCache repo) case mtid of Just tid -> withStorage $ loadPackageById (RPLIRepo repo pm) tid Nothing -> do package <- inner withStorage $ do ment <- getTreeForKey $ packageTreeKey package case ment of Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) Just (Entity tid _) -> storeRepoCache repo (repoSubdir repo) tid pure package getRepo' :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageMetadata -> RIO env Package getRepo' repo@Repo{..} rpm = do withRepoArchive (rToSimpleRepo repo) $ \tarball -> do abs' <- resolveFile' tarball getArchivePackage (RPLIRepo repo rpm) RawArchive { raLocation = ALFilePath $ ResolvedPath { resolvedRelative = RelFilePath $ T.pack tarball , resolvedAbsolute = abs' } , raHash = Nothing , raSize = Nothing , raSubdir = repoSubdir } rpm getRepos :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => AggregateRepo -> RIO env [Package] getRepos repo@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = withCache getRepos' where withCache inner = do pkgs <- forM repoSubdirs $ \(subdir, rpm) -> withStorage $ do loadRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) >>= \case Just tid -> fmap Right $ (, subdir) <$> loadPackageById (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) tid Nothing -> pure $ Left (subdir, rpm) let (missingPkgs, cachedPkgs) = partitionEithers pkgs newPkgs <- if null missingPkgs then pure [] else do packages <- inner repo { aRepoSubdirs = missingPkgs } forM packages $ \(package, subdir) -> do withStorage $ do ment <- getTreeForKey $ packageTreeKey package case ment of Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) Just (Entity tid _) -> storeRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) subdir tid pure package pure (nubOrd ((fst <$> cachedPkgs) ++ newPkgs)) getRepos' :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => AggregateRepo -> RIO env [(Package, Text)] -- ^ [(package, subdir)] getRepos' ar@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = do withRepoArchive (arToSimpleRepo ar) $ \tarball -> do abs' <- resolveFile' tarball forM repoSubdirs $ \(subdir, rpm) -> do (,subdir) <$> getArchivePackage (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) RawArchive { raLocation = ALFilePath $ ResolvedPath { resolvedRelative = RelFilePath $ T.pack tarball , resolvedAbsolute = abs' } , raHash = Nothing , raSize = Nothing , raSubdir = subdir } rpm -- | Fetch a repository and create a (temporary) tar archive from it. Pass the -- path of the generated tarball to the given action. withRepoArchive :: forall env a. (HasLogFunc env, HasProcessContext env) => SimpleRepo -> (FilePath -> RIO env a) -> RIO env a withRepoArchive sr action = withSystemTempDirectory "with-repo-archive" $ \tmpdirArchive -> do let tarball = tmpdirArchive "foo.tar" createRepoArchive sr tarball action tarball -- | Run a git command, setting appropriate environment variable settings. See -- . runGitCommand :: (HasLogFunc env, HasProcessContext env) => [String] -- ^ args -> RIO env () runGitCommand args = withModifyEnvVars go $ void $ proc "git" args readProcess_ where go = Map.delete "GIT_DIR" . Map.delete "GIT_CEILING_DIRECTORIES" . Map.delete "GIT_WORK_TREE" . Map.delete "GIT_INDEX_FILE" . Map.delete "GIT_OBJECT_DIRECTORY" -- possible optimization: set this to something Pantry controls . Map.delete "GIT_ALTERNATE_OBJECT_DIRECTORIES" -- Include submodules files into the archive: use `git submodule foreach` to -- execute `git archive` in each submodule and generate tar archive. With bsd -- tar, the generated archive is extracted to a temporary folder and the files -- in them are added to the tarball referenced by the variable tarball in the -- haskell code. This is done in GNU tar with -A option. archiveSubmodules :: (HasLogFunc env, HasProcessContext env) => FilePath -> RIO env () archiveSubmodules tarball = do tarType <- getGitTarType let forceLocal = if osIsWindows then " --force-local " else mempty case tarType of Gnu -> do -- Single quotation marks are required around tarball because otherwise, -- in the foreach environment, the \ character in absolute paths on -- Windows will be interpreted as escaping the following character. let foreachCommand = "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; " <> "tar" <> forceLocal <> " -Af '" <> tarball <> "' bar.tar" runGitCommand [ "submodule" , "foreach" , "--recursive" , foreachCommand ] Bsd -> runGitCommand [ "submodule" , "foreach" , "--recursive" , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; " <> "rm -rf temp; mkdir temp; mv bar.tar temp/; " <> "tar -C temp -xf temp/bar.tar; " <> "rm temp/bar.tar; " <> "tar -C temp -rf " <> tarball <> " . ;" ] -- | Run an hg command runHgCommand :: (HasLogFunc env, HasProcessContext env) => [String] -- ^ args -> RIO env () runHgCommand args = void $ proc "hg" args readProcess_ -- | Create a tarball containing files from a repository createRepoArchive :: forall env. (HasLogFunc env, HasProcessContext env) => SimpleRepo -> FilePath -- ^ Output tar archive filename -> RIO env () createRepoArchive sr tarball = do withRepo sr $ case sRepoType sr of RepoGit -> do runGitCommand ["-c", "core.autocrlf=false", "archive", "-o", tarball, "HEAD"] archiveSubmodules tarball RepoHg -> runHgCommand ["archive", tarball, "-X", ".hg_archival.txt"] -- | Clone the repository (and, in the case of Git and if necessary, fetch the -- specific commit) and execute the action with the working directory set to the -- repository root. -- -- @since 0.1.0.0 withRepo :: forall env a. (HasLogFunc env, HasProcessContext env) => SimpleRepo -> RIO env a -> RIO env a withRepo sr@SimpleRepo{..} action = withSystemTempDirectory "with-repo" $ \tmpDir -> do let repoUrl = T.unpack sRepoUrl repoCommit = T.unpack sRepoCommit dir = tmpDir "cloned" (runCommand, resetArgs) = case sRepoType of RepoGit -> ( runGitCommand , ["reset", "--hard", repoCommit] ) RepoHg -> ( runHgCommand , ["update", "-C", repoCommit] ) fetchCommit = ["fetch", repoUrl, repoCommit] submoduleArgs = ["submodule", "update", "--init", "--recursive"] fixANSIForWindows = -- On Windows 10, an upstream issue with the `git clone` command means -- that command clears, but does not then restore, the -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The -- following hack re-enables the lost ANSI-capability. when osIsWindows $ void $ liftIO $ #if MIN_VERSION_ansi_terminal(1, 0, 2) hNowSupportsANSI stdout #else hSupportsANSIWithoutEmulation stdout #endif logInfo $ "Cloning " <> display sRepoCommit <> " from " <> display sRepoUrl runCommand ["clone", repoUrl, dir] fixANSIForWindows created <- doesDirectoryExist dir unless created $ throwIO $ FailedToCloneRepo sr -- Note we do not immediately change directories into the new temporary -- directory, but instead wait until we have finished cloning the repo. This -- is because the repo URL may be a relative path on the local filesystem, -- and we should interpret it as relative to the current directory, not the -- temporary directory. withWorkingDir dir $ do case sRepoType of RepoGit -> do catch -- This will result in a failure exit code if the specified commit -- is not in the clone of the repository. (runCommand resetArgs) ( \(_ :: ExitCodeException) -> do -- Perhaps the specified commit is not one that is brought across -- by `git clone`. For example, in the case of a GitHub -- repository, it may be a commit from a different repository -- that is the subject of an unmerged pull request. Try to fetch -- the specific commit and then try again. runCommand fetchCommit runCommand resetArgs ) runCommand submoduleArgs fixANSIForWindows RepoHg -> runCommand resetArgs action pantry-0.9.3.2/src/Pantry/Storage.hs0000644000000000000000000012121114564442767015413 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} module Pantry.Storage ( SqlBackend , initStorage , withStorage , migrateAll , storeBlob , loadBlob , loadBlobById , loadBlobBySHA , allBlobsSource , allHackageCabalRawPackageLocations , allBlobsCount , allHackageCabalCount , getBlobKey , loadURLBlob , storeURLBlob , clearHackageRevisions , storeHackageRevision , loadHackagePackageVersions , loadHackagePackageVersion , loadLatestCacheUpdate , storeCacheUpdate , storeHackageTarballInfo , loadHackageTarballInfo , getHPackBlobKeyById , storeTree , loadTree , storeHPack , loadPackageById , getPackageNameById , getPackageNameId , getVersionId , getTreeForKey , storeHackageTree , loadHackageTree , loadHackageTreeKey , storeArchiveCache , loadArchiveCache , storeRepoCache , loadRepoCache , storePreferredVersion , loadPreferredVersion , sinkHackagePackageNames , loadCabalBlobKey , hpackToCabal , countHackageCabals , getSnapshotCacheByHash , getSnapshotCacheId , storeSnapshotModuleCache , loadExposedModulePackages , findOrGenerateCabalFile , PackageNameId , PackageName , VersionId , ModuleNameId , Version , versionVersion , Unique(..) , EntityField(..) -- avoid warnings , BlobId , Key(unBlobKey) , HackageCabalId , HackageCabal(..) , HackageTarballId , CacheUpdateId , FilePathId , Tree(..) , TreeId , TreeEntry(..) , TreeEntryId , ArchiveCacheId , RepoCacheId , PreferredVersionsId , UrlBlobId , SnapshotCacheId , PackageExposedModuleId , loadCachedTree , CachedTree (..) , unCachedTree ) where import Conduit ( ConduitT, (.|), concatMapMC, mapC, runConduit ) import Data.Acquire ( with ) import Database.Persist ( ( !=.), (=.), (==.), (>.) ) import Database.Persist.Class.PersistEntity ( Entity (..), EntityField, Filter (..), Key, SelectOpt (..) , Unique ) import Database.Persist.Class.PersistField ( PersistField (..) ) import Database.Persist.Class.PersistQuery ( count, deleteWhere, selectFirst, selectKeysList, selectList , selectSource, selectSourceRes, updateWhere ) import Database.Persist.Class.PersistStore ( get, getJust, insert, insert_, update, ) import Database.Persist.Class.PersistUnique ( getBy, insertBy ) import Database.Persist.Sql ( Single (..), rawExecute, rawSql ) import Database.Persist.SqlBackend ( SqlBackend ) import Database.Persist.TH ( mkMigrate, mkPersist, persistLowerCase, share, sqlSettings ) import Pantry.HPack ( hpack, hpackVersion ) import qualified Pantry.SHA256 as SHA256 import qualified Pantry.SQLite as SQLite import Pantry.Types ( BlobKey, FileSize (..), FileType (..), HasPantryConfig , Package (..), PackageNameP (..), Repo (..), Revision (..) , SHA256, SafeFilePath, SnapshotCacheHash (..), TreeKey , VersionP (..), connRDBMS ) import qualified Pantry.Types as P import Path ( Abs, Dir, File, Path, filename, fromAbsFile, fromRelFile , parseAbsDir, toFilePath ) import Path.IO ( createTempDir, getTempDir, listDir, removeDirRecur ) import RIO hiding ( FilePath ) import qualified RIO.ByteString as B import RIO.Directory ( createDirectoryIfMissing, getPermissions , setOwnerExecutable, setPermissions ) import RIO.FilePath ( (), takeDirectory ) import qualified RIO.FilePath as FilePath import qualified RIO.List as List import qualified RIO.Map as Map import RIO.Orphans ( HasResourceMap ) import RIO.Process ( HasProcessContext ) import qualified RIO.Text as T import RIO.Time ( UTCTime, getCurrentTime ) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- Raw blobs Blob sha SHA256 size FileSize contents ByteString UniqueBlobSha sha -- Previously downloaded blobs from given URLs. -- May change over time, so we keep a time column too. UrlBlob sql=url_blob url Text blob BlobId time UTCTime UniqueUrlTime url time -- For normalization, and avoiding storing strings in a bunch of -- tables. PackageName name P.PackageNameP UniquePackageName name Version version P.VersionP UniqueVersion version FilePath path P.SafeFilePath UniqueSfp path -- Secure download information for a package on Hackage. This does not -- contain revision information, since sdist tarballs are (blessedly) -- unmodified on Hackage. HackageTarball name PackageNameId version VersionId sha SHA256 size FileSize UniqueHackageTarball name version -- An individual cabal file from Hackage, representing a specific -- revision. HackageCabal name PackageNameId version VersionId revision P.Revision cabal BlobId -- If available: the full tree containing the HackageTarball -- contents with the cabal file modified. tree TreeId Maybe UniqueHackage name version revision -- Any preferred-version information from Hackage PreferredVersions name PackageNameId preferred Text UniquePreferred name -- Last time we downloaded a 01-index.tar file from Hackage and -- updated the three previous tables. CacheUpdate -- When did we do the update? time UTCTime -- How big was the file when we updated, ignoring the last two -- all-null 512-byte blocks. size FileSize -- SHA256 of the first 'size' bytes of the file sha SHA256 -- A tree containing a Haskell package. See associated TreeEntry -- table. Tree key BlobId -- If the treeCabal field is Nothing, it means the Haskell package -- doesn't have a corresponding cabal file for it. This may be the case -- for haskell package referenced by git repository with only a hpack file. cabal BlobId Maybe cabalType FileType name PackageNameId version VersionId UniqueTree key HPack tree TreeId -- hpack version used for generating this cabal file version VersionId -- Generated cabal file for the given tree and hpack version cabalBlob BlobId cabalPath FilePathId UniqueHPack tree version -- An individual file within a Tree. TreeEntry tree TreeId path FilePathId blob BlobId type FileType -- Like UrlBlob, but stores the contents as a Tree. ArchiveCache time UTCTime url Text subdir Text sha SHA256 size FileSize tree TreeId -- Like ArchiveCache, but for a Repo. RepoCache time UTCTime url Text type P.RepoType commit Text subdir Text tree TreeId -- Identified by sha of all immutable packages contained in a snapshot -- and GHC version used SnapshotCache sha SHA256 UniqueSnapshotCache sha PackageExposedModule snapshotCache SnapshotCacheId module ModuleNameId package PackageNameId ModuleName name P.ModuleNameP UniqueModule name |] initStorage :: HasLogFunc env => Path Abs File -- ^ storage file -> (P.Storage -> RIO env a) -> RIO env a initStorage = SQLite.initStorage "Pantry" migrateAll withStorage :: (HasPantryConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) a -> RIO env a withStorage action = do storage <- view (P.pantryConfigL.to P.pcStorage) SQLite.withStorage_ storage action -- | This is a helper type to distinguish db queries between different rdbms -- backends. The important part is that the affects described in this data type -- should be semantically equivalent between the supported engines. data RdbmsActions env a = RdbmsActions { raSqlite :: !(ReaderT SqlBackend (RIO env) a) -- ^ A query that is specific to SQLite , raPostgres :: !(ReaderT SqlBackend (RIO env) a) -- ^ A query that is specific to PostgreSQL } -- | This function provides a way to create queries supported by multiple sql -- backends. rdbmsAwareQuery :: RdbmsActions env a -> ReaderT SqlBackend (RIO env) a rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do rdbms <- Pantry.Types.connRDBMS <$> ask case rdbms of "postgresql" -> raPostgres "sqlite" -> raSqlite _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" getPackageNameById :: PackageNameId -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName) getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get getPackageNameId :: P.PackageName -> ReaderT SqlBackend (RIO env) PackageNameId getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP getVersionId :: P.Version -> ReaderT SqlBackend (RIO env) VersionId getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP storeBlob :: ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) storeBlob bs = do let sha = SHA256.hashBytes bs size = FileSize $ fromIntegral $ B.length bs keys <- selectKeysList [BlobSha ==. sha] [] key <- case keys of [] -> rdbmsAwareQuery RdbmsActions { raSqlite = insert Blob {blobSha = sha, blobSize = size, blobContents = bs} , raPostgres = do rawExecute "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON \ \CONFLICT DO NOTHING" [ toPersistValue sha , toPersistValue size , toPersistValue bs ] rawSql "SELECT blob.id FROM blob WHERE blob.sha = ?" [toPersistValue sha] >>= \case [Single key] -> pure key _ -> error "soreBlob: there was a critical problem storing a blob." } key:rest -> assert (null rest) (pure key) pure (key, P.BlobKey sha size) loadBlob :: HasLogFunc env => BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString) loadBlob (P.BlobKey sha size) = do ment <- getBy $ UniqueBlobSha sha case ment of Nothing -> pure Nothing Just (Entity _ bt) | blobSize bt == size -> pure $ Just $ blobContents bt | otherwise -> Nothing <$ lift (logWarn $ "Mismatched blob size detected for SHA " <> display sha <> ". Expected size: " <> display size <> ". Actual size: " <> display (blobSize bt)) loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId) loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString loadBlobById bid = do mbt <- get bid case mbt of Nothing -> error "loadBlobById: ID doesn't exist in database" Just bt -> pure $ blobContents bt allBlobsSource :: HasResourceMap env => Maybe BlobId -- ^ For some x, yield blob whose id>x. -> ConduitT () (BlobId, ByteString) (ReaderT SqlBackend (RIO env)) () allBlobsSource mblobId = selectSource [BlobId >. blobId | Just blobId <- [mblobId]] [Asc BlobId] .| mapC (entityKey &&& blobContents . entityVal) -- | Pull all hackage cabal entries from the database as -- 'RawPackageLocationImmutable'. We do a manual join rather than dropping to -- raw SQL, and Esqueleto would add more deps. allHackageCabalRawPackageLocations :: HasResourceMap env => Maybe HackageCabalId -- ^ For some x, yield cabals whose id>x. -> ReaderT SqlBackend (RIO env) (Map.Map HackageCabalId P.RawPackageLocationImmutable) allHackageCabalRawPackageLocations mhackageId = do hackageCabals :: Map HackageCabalId HackageCabal <- selectTuples [HackageCabalId >. hackageId | Just hackageId <- [mhackageId]] [] packageNames :: Map PackageNameId PackageName <- selectTuples [] [] versions :: Map VersionId Version <- selectTuples [] [] for hackageCabals (\hackageCabal -> case Map.lookup (hackageCabalName hackageCabal) packageNames of Nothing -> error "no such package name" Just packageName -> let P.PackageNameP packageName' = packageNameName packageName in case Map.lookup (hackageCabalVersion hackageCabal) versions of Nothing -> error "no such version" Just version -> let P.VersionP version' = versionVersion version in do mtree <- case hackageCabalTree hackageCabal of Just key -> selectFirst [TreeId ==. key] [] Nothing -> pure Nothing mblobKey <- maybe (pure Nothing) ((fmap Just . getBlobKey) . treeKey . entityVal) mtree pure (P.RPLIHackage (P.PackageIdentifierRevision packageName' version' (P.CFIRevision (hackageCabalRevision hackageCabal))) (fmap P.TreeKey mblobKey))) where selectTuples pred sort = fmap (Map.fromList . map tuple) (selectList pred sort) tuple (Entity k v) = (k, v) allBlobsCount :: Maybe BlobId -> ReaderT SqlBackend (RIO env) Int allBlobsCount mblobId = count [BlobId >. blobId | Just blobId <- [mblobId]] allHackageCabalCount :: Maybe HackageCabalId -> ReaderT SqlBackend (RIO env) Int allHackageCabalCount mhackageCabalId = count [ HackageCabalId >. hackageCabalId | Just hackageCabalId <- [mhackageCabalId] ] getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey getBlobKey bid = do res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] case res of [] -> error $ "getBlobKey failed due to missing ID: " ++ show bid [(Single sha, Single size)] -> pure $ P.BlobKey sha size _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId) getBlobId (P.BlobKey sha size) = do res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" [toPersistValue sha, toPersistValue size] pure $ listToMaybe $ map unSingle res loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString) loadURLBlob url = do ment <- rawSql "SELECT blob.contents\n\ \FROM blob, url_blob\n\ \WHERE url=?\ \ AND url_blob.blob=blob.id\n\ \ ORDER BY url_blob.time DESC" [toPersistValue url] case ment of [] -> pure Nothing (Single bs) : _ -> pure $ Just bs storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) () storeURLBlob url blob = do (blobId, _) <- storeBlob blob now <- getCurrentTime insert_ UrlBlob { urlBlobUrl = url , urlBlobBlob = blobId , urlBlobTime = now } clearHackageRevisions :: ReaderT SqlBackend (RIO env) () clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) storeHackageRevision :: P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) () storeHackageRevision name version key = do nameid <- getPackageNameId name versionid <- getVersionId version rev <- count [ HackageCabalName ==. nameid , HackageCabalVersion ==. versionid ] insert_ HackageCabal { hackageCabalName = nameid , hackageCabalVersion = versionid , hackageCabalRevision = Revision (fromIntegral rev) , hackageCabalCabal = key , hackageCabalTree = Nothing } loadHackagePackageVersions :: P.PackageName -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) loadHackagePackageVersions name = do nameid <- getPackageNameId name -- would be better with esqueleto Map.fromListWith Map.union . map go <$> rawSql "SELECT hackage.revision, version.version, blob.sha, blob.size\n\ \FROM hackage_cabal as hackage, version, blob\n\ \WHERE hackage.name=?\n\ \AND hackage.version=version.id\n\ \AND hackage.cabal=blob.id" [toPersistValue nameid] where go (Single revision, Single (P.VersionP version), Single key, Single size) = (version, Map.singleton revision (P.BlobKey key size)) loadHackagePackageVersion :: P.PackageName -> P.Version -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) loadHackagePackageVersion name version = do nameid <- getPackageNameId name versionid <- getVersionId version -- would be better with esqueleto Map.fromList . map go <$> rawSql "SELECT hackage.revision, blob.sha, blob.size, blob.id\n\ \FROM hackage_cabal as hackage, version, blob\n\ \WHERE hackage.name=?\n\ \AND hackage.version=?\n\ \AND hackage.cabal=blob.id" [toPersistValue nameid, toPersistValue versionid] where go (Single revision, Single sha, Single size, Single bid) = (revision, (bid, P.BlobKey sha size)) loadLatestCacheUpdate :: ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime] where go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) () storeCacheUpdate size sha = do now <- getCurrentTime insert_ CacheUpdate { cacheUpdateTime = now , cacheUpdateSize = size , cacheUpdateSha = sha } storeHackageTarballInfo :: P.PackageName -> P.Version -> SHA256 -> FileSize -> ReaderT SqlBackend (RIO env) () storeHackageTarballInfo name version sha size = do nameid <- getPackageNameId name versionid <- getVersionId version void $ insertBy HackageTarball { hackageTarballName = nameid , hackageTarballVersion = versionid , hackageTarballSha = sha , hackageTarballSize = size } loadHackageTarballInfo :: P.PackageName -> P.Version -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) loadHackageTarballInfo name version = do nameid <- getPackageNameId name versionid <- getVersionId version fmap go <$> getBy (UniqueHackageTarball nameid versionid) where go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) storeCabalFile :: ByteString -> P.PackageName -> ReaderT SqlBackend (RIO env) BlobId storeCabalFile cabalBS pkgName = do (bid, _) <- storeBlob cabalBS let cabalFile = P.cabalFileName pkgName _ <- insertBy FilePath {filePathPath = cabalFile} pure bid loadFilePath :: SafeFilePath -> ReaderT SqlBackend (RIO env) (Entity FilePath) loadFilePath path = do fp <- getBy $ UniqueSfp path case fp of Nothing -> error $ "loadFilePath: No row found for " <> T.unpack (P.unSafeFilePath path) Just record -> pure record loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) loadHPackTreeEntity tid = do filepath <- loadFilePath P.hpackSafeFilePath let filePathId :: FilePathId = entityKey filepath hpackTreeEntry <- selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] case hpackTreeEntry of Nothing -> error $ "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ show tid Just record -> pure record storeHPack :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -> TreeId -> ReaderT SqlBackend (RIO env) (Key HPack) storeHPack rpli tid = do vid <- hpackVersionId hpackRecord <- getBy (UniqueHPack tid vid) case hpackRecord of Nothing -> generateHPack rpli tid vid Just record -> pure $ entityKey record loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey loadCabalBlobKey hpackId = do hpackRecord <- getJust hpackId getBlobKey $ hPackCabalBlob hpackRecord generateHPack :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> TreeId -> VersionId -> ReaderT SqlBackend (RIO env) (Key HPack) generateHPack rpli tid vid = do tree <- getTree tid (pkgName, cabalBS) <- hpackToCabalS rpli tree bid <- storeCabalFile cabalBS pkgName let cabalFile = P.cabalFileName pkgName fid <- insertBy FilePath {filePathPath = cabalFile} let hpackRecord = HPack { hPackTree = tid , hPackVersion = vid , hPackCabalBlob = bid , hPackCabalPath = either entityKey id fid } either entityKey id <$> insertBy hpackRecord hpackVersionId :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => ReaderT SqlBackend (RIO env) VersionId hpackVersionId = do hpackSoftwareVersion <- lift hpackVersion fmap (either entityKey id) $ insertBy $ Version {versionVersion = P.VersionP hpackSoftwareVersion} getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId getFilePathId sfp = selectKeysList [FilePathPath ==. sfp] [] >>= \case [fpId] -> pure fpId [] -> rdbmsAwareQuery RdbmsActions { raSqlite = insert $ FilePath sfp , raPostgres = do rawExecute "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" [toPersistValue sfp] rawSql "SELECT id FROM file_path WHERE path = ?" [toPersistValue sfp] >>= \case [Single key] -> pure key _ -> error "getFilePathId: there was a critical problem storing a blob." } _ -> error $ "getFilePathId: FilePath unique constraint key is violated for: " ++ fp where fp = T.unpack (P.unSafeFilePath sfp) -- | A tree that has already been stored in the database newtype CachedTree = CachedTreeMap (Map SafeFilePath (P.TreeEntry, BlobId)) deriving Show unCachedTree :: CachedTree -> P.Tree unCachedTree (CachedTreeMap m) = P.TreeMap $ fst <$> m storeTree :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.PackageIdentifier -> CachedTree -> P.BuildFile -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey) storeTree rpli (P.PackageIdentifier name version) tree@(CachedTreeMap m) buildFile = do (bid, blobKey) <- storeBlob $ P.renderTree $ unCachedTree tree (cabalid, ftype) <- case buildFile of P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype) P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do buildTypeid <- loadBlobBySHA btypeSha buildid <- case buildTypeid of Just buildId -> pure buildId Nothing -> error $ "storeTree: " ++ show buildFile ++ " BlobKey not found: " ++ show (tree, btypeSha) pure (Just buildid, ftype) nameid <- getPackageNameId name versionid <- getVersionId version etid <- insertBy Tree { treeKey = bid , treeCabal = cabalid , treeCabalType = ftype , treeName = nameid , treeVersion = versionid } (tid, pTreeKey) <- case etid of Left (Entity tid _) -> pure (tid, P.TreeKey blobKey) -- already in database, assume it matches Right tid -> do for_ (Map.toList m) $ \(sfp, (P.TreeEntry _blobKey ft, bid')) -> do sfpid <- getFilePathId sfp insert_ TreeEntry { treeEntryTree = tid , treeEntryPath = sfpid , treeEntryBlob = bid' , treeEntryType = ft } pure (tid, P.TreeKey blobKey) case buildFile of P.BFHpack _ -> void $ storeHPack rpli tid P.BFCabal _ _ -> pure () pure (tid, pTreeKey) getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree getTree tid = do (mts :: Maybe Tree) <- get tid ts <- case mts of Nothing -> error $ "getTree: invalid foreign key " ++ show tid Just ts -> pure ts loadTreeByEnt $ Entity tid ts loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) loadTree key = do ment <- getTreeForKey key case ment of Nothing -> pure Nothing Just ent -> Just <$> loadTreeByEnt ent getTreeForKey :: TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) getTreeForKey (P.TreeKey key) = do mbid <- getBlobId key case mbid of Nothing -> pure Nothing Just bid -> getBy $ UniqueTree bid loadPackageById :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> TreeId -> ReaderT SqlBackend (RIO env) Package loadPackageById rpli tid = do (mts :: Maybe Tree) <- get tid ts <- case mts of Nothing -> error $ "loadPackageById: invalid foreign key " ++ show tid Just ts -> pure ts (tree :: P.Tree) <- loadTreeByEnt $ Entity tid ts (blobKey :: BlobKey) <- getBlobKey $ treeKey ts (mname :: Maybe PackageName) <- get $ treeName ts name <- case mname of Nothing -> error $ "loadPackageByid: invalid foreign key " ++ show (treeName ts) Just (PackageName (P.PackageNameP name)) -> pure name mversion <- get $ treeVersion ts version <- case mversion of Nothing -> error $ "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) Just (Version (P.VersionP version)) -> pure version let ident = P.PackageIdentifier name version (packageEntry, mtree) <- case treeCabal ts of Just keyBlob -> do cabalKey <- getBlobKey keyBlob pure ( P.PCCabalFile $ P.TreeEntry cabalKey (treeCabalType ts) , tree) Nothing -> do hpackVid <- hpackVersionId hpackEntity <- getBy (UniqueHPack tid hpackVid) let (P.TreeMap tmap) = tree cabalFile = P.cabalFileName name case hpackEntity of Nothing -> do -- This case will happen when you either update stack with a new hpack -- version or use different hpack version via --with-hpack option. (hpackId :: HPackId) <- storeHPack rpli tid hpackRecord <- getJust hpackId getHPackCabalFile hpackRecord ts tmap cabalFile Just (Entity _ item) -> getHPackCabalFile item ts tmap cabalFile pure Package { packageTreeKey = P.TreeKey blobKey , packageTree = mtree , packageCabalEntry = packageEntry , packageIdent = ident } getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey getHPackBlobKey hpackRecord = do let treeId = hPackTree hpackRecord hpackEntity <- loadHPackTreeEntity treeId getBlobKey (treeEntryBlob $ entityVal hpackEntity) getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey getHPackBlobKeyById hpackId = do hpackRecord <- getJust hpackId getHPackBlobKey hpackRecord getHPackCabalFile :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => HPack -> Tree -> Map SafeFilePath P.TreeEntry -> SafeFilePath -> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree) getHPackCabalFile hpackRecord ts tmap cabalFile = do cabalKey <- getBlobKey (hPackCabalBlob hpackRecord) hpackKey <- getHPackBlobKey hpackRecord hpackSoftwareVersion <- lift hpackVersion let fileType = treeCabalType ts cbTreeEntry = P.TreeEntry cabalKey fileType hpackTreeEntry = P.TreeEntry hpackKey fileType tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap pure ( P.PCHpack $ P.PHpack { P.phOriginal = hpackTreeEntry , P.phGenerated = cbTreeEntry , P.phVersion = hpackSoftwareVersion } , tree ) loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree loadTreeByEnt (Entity tid _t) = do entries <- rawSql "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ \FROM tree_entry, blob, file_path\n\ \WHERE tree_entry.tree=?\n\ \AND tree_entry.blob=blob.id\n\ \AND tree_entry.path=file_path.id" [toPersistValue tid] pure $ P.TreeMap $ Map.fromList $ map (\(Single sfp, Single sha, Single size, Single ft) -> (sfp, P.TreeEntry (P.BlobKey sha size) ft)) entries storeHackageTree :: P.PackageName -> P.Version -> BlobId -> P.TreeKey -> ReaderT SqlBackend (RIO env) () storeHackageTree name version cabal treeKey' = do nameid <- getPackageNameId name versionid <- getVersionId version ment <- getTreeForKey treeKey' for_ ment $ \ent -> updateWhere [ HackageCabalName ==. nameid , HackageCabalVersion ==. versionid , HackageCabalCabal ==. cabal ] [HackageCabalTree =. Just (entityKey ent)] loadHackageTreeKey :: P.PackageName -> P.Version -> SHA256 -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) loadHackageTreeKey name ver sha = do res <- rawSql "SELECT treeblob.sha, treeblob.size\n\ \FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\ \WHERE package_name.name=?\n\ \AND version.version=?\n\ \AND cabalblob.sha=?\n\ \AND hackage_cabal.name=package_name.id\n\ \AND hackage_cabal.version=version.id\n\ \AND hackage_cabal.cabal=cabalblob.id\n\ \AND hackage_cabal.tree=tree.id\n\ \AND tree.key=treeblob.id" [ toPersistValue $ P.PackageNameP name , toPersistValue $ P.VersionP ver , toPersistValue sha ] case res of [] -> pure Nothing (Single treesha, Single size):_ -> pure $ Just $ P.TreeKey $ P.BlobKey treesha size loadHackageTree :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) (Maybe Package) loadHackageTree rpli name ver bid = do nameid <- getPackageNameId name versionid <- getVersionId ver ment <- selectFirst [ HackageCabalName ==. nameid , HackageCabalVersion ==. versionid , HackageCabalCabal ==. bid , HackageCabalTree !=. Nothing ] [] case ment of Nothing -> pure Nothing Just (Entity _ hc) -> case hackageCabalTree hc of Nothing -> assert False $ pure Nothing Just tid -> Just <$> loadPackageById rpli tid storeArchiveCache :: Text -- ^ URL -> Text -- ^ subdir -> SHA256 -> FileSize -> P.TreeKey -> ReaderT SqlBackend (RIO env) () storeArchiveCache url subdir sha size treeKey' = do now <- getCurrentTime ment <- getTreeForKey treeKey' for_ ment $ \ent -> insert_ ArchiveCache { archiveCacheTime = now , archiveCacheUrl = url , archiveCacheSubdir = subdir , archiveCacheSha = sha , archiveCacheSize = size , archiveCacheTree = entityKey ent } loadArchiveCache :: Text -- ^ URL -> Text -- ^ subdir -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] loadArchiveCache url subdir = map go <$> selectList [ ArchiveCacheUrl ==. url , ArchiveCacheSubdir ==. subdir ] [Desc ArchiveCacheTime] where go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) storeRepoCache :: Repo -> Text -- ^ subdir -> TreeId -> ReaderT SqlBackend (RIO env) () storeRepoCache repo subdir tid = do now <- getCurrentTime insert_ RepoCache { repoCacheTime = now , repoCacheUrl = repoUrl repo , repoCacheType = repoType repo , repoCacheCommit = repoCommit repo , repoCacheSubdir = subdir , repoCacheTree = tid } loadRepoCache :: Repo -> ReaderT SqlBackend (RIO env) (Maybe TreeId) loadRepoCache repo = fmap (repoCacheTree . entityVal) <$> selectFirst [ RepoCacheUrl ==. repoUrl repo , RepoCacheType ==. repoType repo , RepoCacheCommit ==. repoCommit repo , RepoCacheSubdir ==. repoSubdir repo ] [Desc RepoCacheTime] storePreferredVersion :: P.PackageName -> Text -> ReaderT SqlBackend (RIO env) () storePreferredVersion name p = do nameid <- getPackageNameId name ment <- getBy $ UniquePreferred nameid case ment of Nothing -> insert_ PreferredVersions { preferredVersionsName = nameid , preferredVersionsPreferred = p } Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] loadPreferredVersion :: P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text) loadPreferredVersion name = do nameid <- getPackageNameId name fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) sinkHackagePackageNames :: (P.PackageName -> Bool) -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a -> ReaderT SqlBackend (RIO env) a sinkHackagePackageNames predicate sink = do acqSrc <- selectSourceRes [] [] with acqSrc $ \src -> runConduit $ src .| concatMapMC go .| sink where go (Entity nameid (PackageName (PackageNameP name))) | predicate name = do -- Make sure it's actually on Hackage. Would be much more efficient with -- some raw SQL and an inner join, but we don't have a Conduit version -- of rawSql. onHackage <- checkOnHackage nameid pure $ if onHackage then Just name else Nothing | otherwise = pure Nothing checkOnHackage nameid = do cnt <- count [HackageCabalName ==. nameid] pure $ cnt > 0 -- | Get the filename for the cabal file in the given directory. -- -- If no .cabal file is present, or more than one is present, an exception is -- thrown via 'throwM'. -- -- If the directory contains a file named package.yaml, hpack is used to -- generate a .cabal file from it. findOrGenerateCabalFile :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ package directory -> RIO env (P.PackageName, Path Abs File) findOrGenerateCabalFile pkgDir = do hpack pkgDir files <- filter (flip hasExtension "cabal" . toFilePath) . snd <$> listDir pkgDir -- If there are multiple files, ignore files that start with ".". On unix-like -- environments these are hidden, and this character is not valid in package -- names. The main goal is to ignore emacs lock files - see -- https://github.com/commercialhaskell/stack/issues/1897. let isHidden ('.':_) = True isHidden _ = False case filter (not . isHidden . fromRelFile . filename) files of [] -> throwIO $ P.NoCabalFileFound pkgDir [x] -> maybe (throwIO $ P.InvalidCabalFilePath x) (\pn -> pure (pn, x)) $ List.stripSuffix ".cabal" (toFilePath (filename x)) >>= P.parsePackageName _:_ -> throwIO $ P.MultipleCabalFilesFound pkgDir files where hasExtension fp x = FilePath.takeExtension fp == "." ++ x -- | Similar to 'hpackToCabal' but doesn't require a new connection to database. hpackToCabalS :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.Tree -> ReaderT SqlBackend (RIO env) (P.PackageName, ByteString) hpackToCabalS rpli tree = do tmpDir <- lift $ do tdir <- getTempDir createTempDir tdir "hpack-pkg-dir" unpackTreeToDir rpli tmpDir tree (packageName, cfile) <- lift $ findOrGenerateCabalFile tmpDir !bs <- lift $ B.readFile (fromAbsFile cfile) lift $ removeDirRecur tmpDir pure (packageName, bs) hpackToCabal :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.Tree -> RIO env (P.PackageName, ByteString) hpackToCabal rpli tree = withSystemTempDirectory "hpack-pkg-dir" $ \tmpdir -> do tdir <- parseAbsDir tmpdir withStorage $ unpackTreeToDir rpli tdir tree (packageName, cfile) <- findOrGenerateCabalFile tdir bs <- B.readFile (fromAbsFile cfile) pure (packageName, bs) unpackTreeToDir :: (HasPantryConfig env, HasLogFunc env) => P.RawPackageLocationImmutable -- ^ for exceptions -> Path Abs Dir -- ^ dest dir, will be created if necessary -> P.Tree -> ReaderT SqlBackend (RIO env) () unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey ft) -> do let dest = dir T.unpack (P.unSafeFilePath sfp) createDirectoryIfMissing True $ takeDirectory dest mbs <- loadBlob blobKey case mbs of Nothing -> do -- TODO when we have pantry wire stuff, try downloading throwIO $ P.TreeReferencesMissingBlob rpli sfp blobKey Just bs -> do B.writeFile dest bs case ft of FTNormal -> pure () FTExecutable -> liftIO $ do perms <- getPermissions dest setPermissions dest $ setOwnerExecutable True perms countHackageCabals :: ReaderT SqlBackend (RIO env) Int countHackageCabals = do res <- rawSql "SELECT COUNT(*)\n\ \FROM hackage_cabal" [] case res of [] -> pure 0 (Single n):_ -> pure n getSnapshotCacheByHash :: SnapshotCacheHash -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId) getSnapshotCacheByHash = fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash getSnapshotCacheId :: SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId getSnapshotCacheId = fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash getModuleNameId :: P.ModuleName -> ReaderT SqlBackend (RIO env) ModuleNameId getModuleNameId = fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP storeSnapshotModuleCache :: SnapshotCacheId -> Map P.PackageName (Set P.ModuleName) -> ReaderT SqlBackend (RIO env) () storeSnapshotModuleCache cache packageModules = forM_ (Map.toList packageModules) $ \(pn, modules) -> do package <- getPackageNameId pn forM_ modules $ \m -> do moduleName <- getModuleNameId m insert_ PackageExposedModule { packageExposedModuleSnapshotCache = cache , packageExposedModulePackage = package , packageExposedModuleModule = moduleName } loadExposedModulePackages :: SnapshotCacheId -> P.ModuleName -> ReaderT SqlBackend (RIO env) [P.PackageName] loadExposedModulePackages cacheId mName = map go <$> rawSql "SELECT package_name.name\n\ \FROM package_name, package_exposed_module, module_name\n\ \WHERE module_name.name=?\n\ \AND package_exposed_module.snapshot_cache=?\n\ \AND module_name.id=package_exposed_module.module\n\ \AND package_name.id=package_exposed_module.package" [ toPersistValue (P.ModuleNameP mName) , toPersistValue cacheId ] where go (Single (P.PackageNameP m)) = m newtype LoadCachedTreeException = MissingBlob BlobKey deriving (Show, Typeable) instance Exception LoadCachedTreeException -- | Ensure that all blobs needed for this package are present in the cache loadCachedTree :: forall env. P.Tree -> ReaderT SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree) loadCachedTree (P.TreeMap m) = try $ CachedTreeMap <$> traverse loadEntry m where loadEntry :: P.TreeEntry -> ReaderT SqlBackend (RIO env) (P.TreeEntry, BlobId) loadEntry te = (te, ) <$> loadBlob' (P.teBlob te) loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) BlobId loadBlob' blobKey@(P.BlobKey sha _) = do mbid <- loadBlobBySHA sha case mbid of Nothing -> throwIO $ MissingBlob blobKey Just bid -> pure bid pantry-0.9.3.2/src/Pantry/Casa.hs0000644000000000000000000000623114520750057014644 0ustar0000000000000000{-# LANGUAGE DisambiguateRecordFields #-} -- | Integration with the Casa server. module Pantry.Casa where import Database.Persist.Sql ( SqlBackend ) import qualified Casa.Client as Casa import qualified Casa.Types as Casa import Conduit ( ConduitT, ResourceT, (.|), await, mapMC, runConduitRes ) import qualified Data.HashMap.Strict as HM import qualified Pantry.SHA256 as SHA256 import Pantry.Storage ( storeBlob, withStorage ) import Pantry.Types as P ( BlobKey (..), FileSize (..), HasPantryConfig (..) , PantryConfig (..), PantryException (..), Tree, TreeKey (..) , parseTreeM ) import RIO import qualified RIO.ByteString as B -- | Lookup a tree. casaLookupTree :: (HasPantryConfig env, HasLogFunc env) => TreeKey -> RIO env (Maybe (TreeKey, P.Tree)) casaLookupTree (P.TreeKey key) = handleAny (const (pure Nothing)) (withStorage (runConduitRes (casaBlobSource (Identity key) .| mapMC parseTreeM .| await))) -- | Lookup a single blob. If possible, prefer 'casaBlobSource', and query a -- group of keys at once, rather than one at a time. This will have better -- network performance. casaLookupKey :: (HasPantryConfig env, HasLogFunc env) => BlobKey -> RIO env (Maybe ByteString) casaLookupKey key = handleAny (const (pure Nothing)) (fmap (fmap snd) (withStorage (runConduitRes (casaBlobSource (Identity key) .| await)))) -- | A source of blobs given a set of keys. All blobs are automatically stored -- in the local pantry database. casaBlobSource :: (Foldable f, HasPantryConfig env, HasLogFunc env) => f BlobKey -> ConduitT i (BlobKey, ByteString) (ResourceT (ReaderT SqlBackend (RIO env))) () casaBlobSource keys = source .| convert .| store where source = do mCasaConfig <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaConfig case mCasaConfig of Just (pullUrl, maxPerRequest) -> do Casa.blobsSource ( Casa.SourceConfig { sourceConfigUrl = pullUrl , sourceConfigBlobs = toBlobKeyMap keys , sourceConfigMaxBlobsPerRequest = maxPerRequest } ) Nothing -> throwM NoCasaConfig where toBlobKeyMap :: Foldable f => f BlobKey -> HashMap Casa.BlobKey Int toBlobKeyMap = HM.fromList . map unpackBlobKey . toList unpackBlobKey (P.BlobKey sha256 (FileSize fileSize)) = (Casa.BlobKey (SHA256.toRaw sha256), fromIntegral fileSize) convert = mapMC toBlobKeyAndBlob where toBlobKeyAndBlob :: MonadThrow m => (Casa.BlobKey, ByteString) -> m (BlobKey, ByteString) toBlobKeyAndBlob (Casa.BlobKey keyBytes, blob) = do sha256 <- case SHA256.fromRaw keyBytes of Left e -> throwM e Right sha -> pure sha pure (BlobKey sha256 (FileSize (fromIntegral (B.length blob))), blob) store = mapMC insertBlob where insertBlob original@(_key, binary) = do _ <- lift (storeBlob binary) pure original pantry-0.9.3.2/src/Pantry/Tree.hs0000644000000000000000000000470114520750057014674 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ViewPatterns #-} module Pantry.Tree ( unpackTree , rawParseGPD ) where import Distribution.PackageDescription ( GenericPackageDescription ) import Distribution.PackageDescription.Parsec ( parseGenericPackageDescription, runParseResult ) import Distribution.Parsec ( PWarning (..) ) import Pantry.Storage ( loadBlob, withStorage ) import Pantry.Types ( FileType (..), HasPantryConfig, PantryException (..) , RawPackageLocationImmutable, Tree (..), TreeEntry (..) , unSafeFilePath ) import Path ( Abs, Dir, File, Path, toFilePath ) import RIO import qualified RIO.ByteString as B import RIO.Directory ( createDirectoryIfMissing, getPermissions , setOwnerExecutable, setPermissions ) import RIO.FilePath ((), takeDirectory) import qualified RIO.Map as Map import qualified RIO.Text as T unpackTree :: (HasPantryConfig env, HasLogFunc env) => RawPackageLocationImmutable -- for exceptions -> Path Abs Dir -- ^ dest dir, will be created if necessary -> Tree -> RIO env () unpackTree rpli (toFilePath -> dir) (TreeMap m) = do withStorage $ for_ (Map.toList m) $ \(sfp, TreeEntry blobKey ft) -> do let dest = dir T.unpack (unSafeFilePath sfp) createDirectoryIfMissing True $ takeDirectory dest mbs <- loadBlob blobKey case mbs of Nothing -> do -- TODO when we have pantry wire stuff, try downloading throwIO $ TreeReferencesMissingBlob rpli sfp blobKey Just bs -> do B.writeFile dest bs case ft of FTNormal -> pure () FTExecutable -> liftIO $ do perms <- getPermissions dest setPermissions dest $ setOwnerExecutable True perms -- | A helper function that performs the basic character encoding necessary. rawParseGPD :: MonadThrow m => Either RawPackageLocationImmutable (Path Abs File) -> ByteString -> m ([PWarning], GenericPackageDescription) rawParseGPD loc bs = case eres of Left (mversion, errs) -> throwM $ InvalidCabalFile loc mversion (toList errs) warnings Right gpkg -> pure (warnings, gpkg) where (warnings, eres) = runParseResult $ parseGenericPackageDescription bs pantry-0.9.3.2/src/windows/System/IsWindows.hs0000644000000000000000000000031414446516353017426 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} module System.IsWindows ( osIsWindows ) where import RIO ( Bool (..) ) -- | True if using Windows OS. osIsWindows :: Bool osIsWindows = True pantry-0.9.3.2/src/unix/System/IsWindows.hs0000644000000000000000000000032214446516353016716 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} module System.IsWindows ( osIsWindows ) where import RIO ( Bool (..) ) -- | False if not using Windows OS. osIsWindows :: Bool osIsWindows = False pantry-0.9.3.2/int/Pantry/HPack.hs0000644000000000000000000000707314520750057014773 0ustar0000000000000000{-# 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 ( HasPantryConfig, HpackExecutable (..), PantryConfig (..) , Version, pantryConfigL, parseVersionThrowing ) import Path ( Abs, Dir, Path, (), filename, parseRelFile, toFilePath ) import Path.IO ( doesFileExist ) import RIO import RIO.Process ( HasProcessContext, proc, readProcessStdout_, runProcess_ , withWorkingDir ) 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_ pantry-0.9.3.2/int/Pantry/Internal.hs0000644000000000000000000000403514454740300015550 0ustar0000000000000000{-# 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 pantry-0.9.3.2/int/Pantry/SHA256.hs0000644000000000000000000001434314520750057014653 0ustar0000000000000000{-# 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 ( ConduitT ) import qualified Crypto.Hash as Hash ( Digest, SHA256, hash, hashlazy ) import qualified Crypto.Hash.Conduit as Hash ( hashFile, sinkHash ) import Data.Aeson ( FromJSON (..), ToJSON (..), withText ) import qualified Data.ByteArray import qualified Data.ByteArray.Encoding as Mem import Data.StaticBytes ( Bytes32, StaticBytesException, toStaticExact ) import Database.Persist.Class.PersistField ( PersistField (..) ) import Database.Persist.PersistValue ( PersistValue (..) ) import Database.Persist.Sql ( PersistFieldSql (..) ) import Database.Persist.Types ( SqlType (..) ) 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 pantry-0.9.3.2/int/Pantry/Types.hs0000644000000000000000000034162314566347773015134 0ustar0000000000000000{-# 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.Class.PersistField ( PersistField (..) ) import Database.Persist.PersistValue ( PersistValue (..) ) import Database.Persist.Sql ( PersistFieldSql (..), SqlBackend ) #if MIN_VERSION_persistent(2, 13, 0) import Database.Persist.SqlBackend.Internal ( connRDBMS ) #endif import Database.Persist.Types ( SqlType (..) ) 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 ( blankLine, 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.stackage.org@ 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. | LocalNoArchiveFileFound !(Path Abs File) | 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 the\n" <> "'packages' and 'extra-deps' fields defined in its project-level\n" <> "configuration file (usually 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 the\n" <> "'packages' and 'extra-deps' fields defined in its project-level\n" <> "configuration file (usually 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 snapshot (" <> 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 (LocalNoArchiveFileFound path) = "Error: [S-628]\n" <> "Stack looks for packages in the archive files configured in the\n" <> "'extra-deps' field defined in its project-level configuration file\n" <> "(usually stack.yaml)\n" <> "An entry points to " <> fromString (toFilePath path) <> ",\nbut no such archive file could be found." 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 its project-level configuration file" , parens (fillSep ["usually", 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 its project-level configuration file" , parens (fillSep ["usually", 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 snapshot" , 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 (LocalNoArchiveFileFound path) = "[S-628]" <> line <> fillSep [ flow "Stack looks for packages in the archive files configured in" , "the" , style Shell "extra-deps" , flow "field defined in its project-level configuration file" , parens (fillSep ["usually", style File "stack.yaml"]) <> "." , flow "An entry points to" , pretty path , flow "but no such archive file could be found." ] 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) 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" mSnapshot <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"] unresolvedSnapshotParent <- case (mCompiler, mSnapshot) of (Nothing, Nothing) -> fail "Snapshot must have either a compiler or a snapshot" (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" pantry-0.9.3.2/app/test-pretty-exceptions/Main.hs0000644000000000000000000003700014566347773020077 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -- | An executable to allow a person to inspect in a terminal the form of -- Pantry's pretty exceptions. module Main ( main ) where import qualified Data.Conduit.Tar as Tar import Data.Maybe ( fromJust ) import qualified Data.Text as T import qualified Distribution.Parsec.Error as C import qualified Distribution.Parsec.Position as C import qualified Distribution.Parsec.Warning as C import qualified Distribution.Types.PackageName as C import qualified Distribution.Types.Version as C import Options.Applicative ( Parser, (<**>), auto, execParser, fullDesc, header, help , helper, info, long, metavar, option, progDesc, showDefault , strOption, value ) import Network.HTTP.Types.Status ( Status, mkStatus ) import Pantry ( ArchiveLocation (..), BlobKey (..), CabalFileInfo (..) , FileSize (..), FuzzyResults (..), Mismatch (..) , PackageName, PantryException (..), PackageIdentifier (..) , PackageIdentifierRevision (..), PackageMetadata (..) , RawPackageLocationImmutable (..), RawPackageMetadata (..) , RawSnapshotLocation (..), RelFilePath (..), Repo (..) , RepoType (..), ResolvedPath (..), Revision (..), SHA256 , SafeFilePath, SimpleRepo (..), SnapName (..) , TreeKey (..), Version, WantedCompiler (..), mkSafeFilePath ) import Pantry.SHA256 ( hashBytes ) import Path ( File ) import PathAbsExamples ( pathAbsDirExample, pathAbsFileExample , pathAbsFileExamples ) import RIO import qualified RIO.List as L import RIO.NonEmpty ( nonEmpty ) import RIO.PrettyPrint ( pretty, prettyError ) import RIO.PrettyPrint.Simple ( SimplePrettyApp, runSimplePrettyApp ) import RIO.PrettyPrint.StylesUpdate ( StylesUpdate, parseStylesUpdateFromString ) import RIO.Time ( fromGregorian ) import System.Terminal ( hIsTerminalDeviceOrMinTTY, getTerminalWidth ) -- | Type representing options that can be specified at the command line data Options = Options { colours :: String , theme :: Theme } -- | Type representing styles identified by a theme name data Theme = Default | SolarizedDark deriving (Bounded, Enum, Read, Show) options :: Parser Options options = Options <$> strOption ( long "colours" <> metavar "STYLES" <> help "Specify the output styles; STYLES is a colon-delimited \ \sequence of key=value, where 'key' is a style name and \ \'value' is a semicolon-delimited list of 'ANSI' SGR (Select \ \Graphic Rendition) control codes (in decimal). In shells \ \where a semicolon is a command separator, enclose STYLES in \ \quotes." <> value "" ) <*> option auto ( long "theme" <> metavar "THEME" <> help ( "Specify a theme for output styles. THEME is one of: " <> showThemes <> "." ) <> value Default <> showDefault ) where showThemes = L.intercalate " " $ map show ([minBound .. maxBound] :: [Theme]) fromTheme :: Theme -> StylesUpdate fromTheme Default = mempty fromTheme SolarizedDark = parseStylesUpdateFromString "error=31:good=32:shell=35:dir=34:recommendation=32:target=95:module=35:package-component=95:secondary=92:highlight=32" main :: IO () main = do isTerminal <- hIsTerminalDeviceOrMinTTY stderr if isTerminal then do terminalWidth <- fromMaybe 80 <$> getTerminalWidth mainInTerminal terminalWidth =<< execParser opts else putStrLn "This executable is intended to be run with the standard error \ \ channel connected to a terminal. No terminal detected." where opts = info (options <**> helper) ( fullDesc <> progDesc "Allows a person to inspect in a terminal the form of Pantry's \ \pretty exceptions." <> header "test-pretty-exceptions - test Pantry's pretty exceptions" ) mainInTerminal :: Int -> Options -> IO () mainInTerminal terminalWidth Options{..} = do let stylesUpdate = fromTheme theme <> parseStylesUpdateFromString colours runSimplePrettyApp terminalWidth stylesUpdate action where action :: RIO SimplePrettyApp () action = mapM_ (prettyError . pretty) examples -- | The intention is that there shoud be examples for every data constructor of -- the PantryException type. examples :: [PantryException] examples = concat [ [ PackageIdentifierRevisionParseFail hackageMsg ] , [ InvalidCabalFile loc version pErrorExamples pWarningExamples | loc <- map Left rawPackageLocationImmutableExamples <> [Right pathAbsFileExample] , version <- [Nothing, Just versionExample] ] , [ TreeWithoutCabalFile rawPackageLocationImmutable | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples ] , [ TreeWithMultipleCabalFiles rawPackageLocationImmutable safeFilePathExamples | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples ] , [ MismatchedCabalName pathAbsFileExample packageNameExample ] , [ NoCabalFileFound pathAbsDirExample ] , [ MultipleCabalFilesFound pathAbsDirExample pathAbsFileExamples ] , [ InvalidWantedCompiler "my-wanted-compiler" ] , [ InvalidSnapshotLocation pathAbsDirExample rawPathExample ] , [ InvalidOverrideCompiler wantedCompiler1 wantedCompiler2 | wantedCompiler1 <- wantedCompilerExamples , wantedCompiler2 <- wantedCompilerExamples ] , [ InvalidFilePathSnapshot rawPathExample ] , [ InvalidSnapshot rawSnapshotLocation someExceptionExample | rawSnapshotLocation <- rawSnapshotLocationExamples ] , [ MismatchedPackageMetadata rawPackageLocationImmutable rawPackageMetadata treeKey packageIdentifierExample | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples , rawPackageMetadata <- rawPackageMetadataExamples , treeKey <- [Nothing, Just treeKeyExample] ] , [ Non200ResponseStatus statusExample ] , [ InvalidBlobKey (Mismatch blobKeyExample blobKeyExample) ] , [ Couldn'tParseSnapshot rawSnapshotLocation errorMessageExample | rawSnapshotLocation <- rawSnapshotLocationExamples ] , [ WrongCabalFileName rawPackageLocationImmutable safeFilePathExample packageNameExample | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples ] , [ DownloadInvalidSHA256 urlExample (Mismatch sha256Example sha256Example) ] , [ DownloadInvalidSize urlExample (Mismatch fileSizeExample fileSizeExample) ] , [ DownloadTooLarge urlExample (Mismatch fileSizeExample fileSizeExample) ] , [ LocalNoArchiveFileFound pathAbsFileExample ] , [ LocalInvalidSHA256 pathAbsFileExample (Mismatch sha256Example sha256Example) ] , [ LocalInvalidSize pathAbsFileExample (Mismatch fileSizeExample fileSizeExample) ] , [ UnknownArchiveType archiveLocation | archiveLocation <- archiveLocationExamples ] , [ InvalidTarFileType archiveLocation filePathExample fileTypeExample | archiveLocation <- archiveLocationExamples ] , [ UnsupportedTarball archiveLocation (T.pack errorMessageExample) | archiveLocation <- archiveLocationExamples ] , [ NoHackageCryptographicHash packageIdentifierExample ] , [ FailedToCloneRepo simpleRepoExample ] , [ TreeReferencesMissingBlob rawPackageLocationImmutable safeFilePathExample blobKeyExample | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples ] , [ CompletePackageMetadataMismatch rawPackageLocationImmutable packageMetadataExample | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples ] , [ CRC32Mismatch archiveLocation filePathExample (Mismatch 1024 1024 ) | archiveLocation <- archiveLocationExamples ] , [ UnknownHackagePackage packageIdentifierRevisionExample fuzzyResults | packageIdentifierRevisionExample <- packageIdentifierRevisionExamples , fuzzyResults <- fuzzyResultsExamples ] , [ CannotCompleteRepoNonSHA1 repoExample ] , [ MutablePackageLocationFromUrl urlExample ] , [ MismatchedCabalFileForHackage packageIdentifierRevision (Mismatch packageIdentifierExample packageIdentifierExample) | packageIdentifierRevision <- packageIdentifierRevisionExamples ] , [ PackageNameParseFail rawPackageName ] , [ PackageVersionParseFail rawPackageVersion ] , [ InvalidCabalFilePath pathAbsFileExample ] , [ DuplicatePackageNames sourceMsgExample duplicatePackageNamesExamples ] , [ MigrationFailure descriptionExample pathAbsFileExample someExceptionExample ] , [ NoCasaConfig ] , [ InvalidTreeFromCasa blobKeyExample blobExample ] , [ ParseSnapNameException rawSnapNameExample ] , [ HpackLibraryException pathAbsFileExample errorMessageExample ] , [ HpackExeException hpackCommandExample pathAbsDirExample someExceptionExample ] ] hackageMsg :: Text hackageMsg = "" pErrorExamples :: [C.PError] pErrorExamples = [ C.PError (C.Position 10 20) "" , C.PError (C.Position 12 10) "" , C.PError (C.Position 14 30) "" ] pWarningExamples :: [C.PWarning] pWarningExamples = [ C.PWarning C.PWTOther (C.Position 10 20) "" , C.PWarning C.PWTOther (C.Position 12 10) "" , C.PWarning C.PWTOther (C.Position 14 30) "" ] packageNameExample :: PackageName packageNameExample = C.mkPackageName "my-package" versionExample :: Version versionExample = C.mkVersion [1, 0, 0] sha256Example :: SHA256 sha256Example = hashBytes "example" fileSizeExample :: FileSize fileSizeExample = FileSize 1234 revisionExample :: Revision revisionExample = Revision 1 cabalFileInfoExamples :: [CabalFileInfo] cabalFileInfoExamples = concat [ [CFILatest] , [ CFIHash sha256Example fileSize | fileSize <- [Nothing, Just fileSizeExample] ] , [CFIRevision revisionExample] ] packageIdentifierRevisionExamples :: [PackageIdentifierRevision] packageIdentifierRevisionExamples = [ PackageIdentifierRevision packageNameExample versionExample cabalFileInfo | cabalFileInfo <- cabalFileInfoExamples ] blobKeyExample :: BlobKey blobKeyExample = BlobKey sha256Example fileSizeExample treeKeyExample :: TreeKey treeKeyExample = TreeKey blobKeyExample rawPackageLocationImmutableExamples :: [RawPackageLocationImmutable] rawPackageLocationImmutableExamples = [ RPLIHackage packageIdentifierRevision treeKey | packageIdentifierRevision <- packageIdentifierRevisionExamples , treeKey <- [Nothing, Just treeKeyExample] ] --, RPLIArchive <> [ RPLIRepo repoExample rawPackageMetadata | rawPackageMetadata <- rawPackageMetadataExamples ] safeFilePathExamples :: [SafeFilePath] safeFilePathExamples = [ fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example1.ext" , fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example2.ext" , fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example3.ext" ] rawPathExample :: Text rawPathExample = "" wantedCompilerExamples :: [WantedCompiler] wantedCompilerExamples = [ WCGhc versionExample , WCGhcGit "" "" , WCGhcjs versionExample versionExample ] newtype ExceptionExample = ExceptionExample Text deriving (Show, Typeable) instance Exception ExceptionExample where displayException (ExceptionExample t) = T.unpack t errorMessageExample :: String errorMessageExample = "This is the first line of some example text for the message in an exception \ \example. This is example text for an exception example.\n\ \This is the second line of some example text for the message in an exception \ \example. This is example text for an exception example." someExceptionExample :: SomeException someExceptionExample = SomeException (ExceptionExample $ T.pack errorMessageExample) urlExample :: Text urlExample = "https://example.com" relFilePathExample :: RelFilePath relFilePathExample = RelFilePath "jane/my-project-dir" resolvedPathFileExample :: ResolvedPath File resolvedPathFileExample = ResolvedPath relFilePathExample pathAbsFileExample snapNameExamples :: [SnapName] snapNameExamples = [ LTS 20 17 , Nightly $ fromGregorian 2023 4 5 ] rawSnapshotLocationExamples :: [RawSnapshotLocation] rawSnapshotLocationExamples = concat [ [ RSLCompiler wantedCompiler | wantedCompiler <- wantedCompilerExamples ] , [ RSLUrl urlExample blobKey | blobKey <- [Nothing, Just blobKeyExample] ] , [ RSLFilePath resolvedPathFileExample ] , [ RSLSynonym snapNameExample | snapNameExample <- snapNameExamples ] ] rawPackageMetadataExamples :: [RawPackageMetadata] rawPackageMetadataExamples = [ RawPackageMetadata name version treeKey | name <- [ Nothing, Just packageNameExample] , version <- [ Nothing, Just versionExample ] , treeKey <- [Nothing, Just treeKeyExample] ] statusExample :: Status statusExample = mkStatus 100 "" safeFilePathExample :: SafeFilePath safeFilePathExample = fromJust $ mkSafeFilePath "Users/jane/my-project-dir/example.ext" archiveLocationExamples :: [ArchiveLocation] archiveLocationExamples = [ ALUrl urlExample , ALFilePath resolvedPathFileExample ] filePathExample :: FilePath filePathExample = "" fileTypeExample :: Tar.FileType fileTypeExample = Tar.FTNormal commitExample :: Text commitExample = "b8b34bf5571de75909d97f687e3d37909b1dc9f7" simpleRepoExample :: SimpleRepo simpleRepoExample = SimpleRepo urlExample commitExample RepoGit packageIdentifierExample :: PackageIdentifier packageIdentifierExample = PackageIdentifier packageNameExample versionExample packageMetadataExample :: PackageMetadata packageMetadataExample = PackageMetadata packageIdentifierExample treeKeyExample fuzzyResultsExamples :: [FuzzyResults] fuzzyResultsExamples = [ FRNameNotFound packageNameExamples , FRVersionNotFound $ fromJust $ nonEmpty packageIdentifierRevisionExamples , FRRevisionNotFound $ fromJust $ nonEmpty packageIdentifierRevisionExamples ] repoExample :: Repo repoExample = Repo urlExample commitExample RepoGit "my-subdirectory" rawPackageName :: Text rawPackageName = "" rawPackageVersion :: Text rawPackageVersion = "" sourceMsgExample :: Utf8Builder sourceMsgExample = "" packageNameExamples :: [PackageName] packageNameExamples = [ C.mkPackageName "my-package1" , C.mkPackageName "my-package2" , C.mkPackageName "my-package3" ] duplicatePackageNamesExamples :: [(PackageName, [RawPackageLocationImmutable])] duplicatePackageNamesExamples = map (, rawPackageLocationImmutableExamples) packageNameExamples descriptionExample :: Text descriptionExample = "" blobExample :: ByteString blobExample = "b8b34bf5571de75909d97f687e3d37909b1dc9f7" rawSnapNameExample :: Text rawSnapNameExample = "" hpackCommandExample :: FilePath hpackCommandExample = "/hpack" pantry-0.9.3.2/app/test-pretty-exceptions/windows/PathAbsExamples.hs0000644000000000000000000000140214414332573023703 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} -- | The module of this name differs as between Windows and non-Windows builds. -- This is the Windows version. module PathAbsExamples ( pathAbsDirExample , pathAbsFileExample , pathAbsFileExamples ) where import Path ( Abs, Dir, File, Path, absdir, absfile ) pathAbsDirExample :: Path Abs Dir pathAbsDirExample = [absdir|C:/Users/jane/my-project-dir|] pathAbsFileExample :: Path Abs File pathAbsFileExample = [absfile|C:/Users/jane/my-project-dir/example.ext|] pathAbsFileExamples :: [Path Abs File] pathAbsFileExamples = [ [absfile|C:/Users/jane/my-project-dir/example1.ext|] , [absfile|C:/Users/jane/my-project-dir/example2.ext|] , [absfile|C:/Users/jane/my-project-dir/example3.ext|] ] pantry-0.9.3.2/app/test-pretty-exceptions/unix/PathAbsExamples.hs0000644000000000000000000000137314414332573023203 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} -- | The module of this name differs as between Windows and non-Windows builds. -- This is the non-Windows version. module PathAbsExamples ( pathAbsDirExample , pathAbsFileExample , pathAbsFileExamples ) where import Path ( Abs, Dir, File, Path, absdir, absfile ) pathAbsDirExample :: Path Abs Dir pathAbsDirExample = [absdir|/home/jane/my-project-dir|] pathAbsFileExample :: Path Abs File pathAbsFileExample = [absfile|/home/jane/my-project-dir/example.ext|] pathAbsFileExamples :: [Path Abs File] pathAbsFileExamples = [ [absfile|/home/jane/my-project-dir/example1.ext|] , [absfile|/home/jane/my-project-dir/example2.ext|] , [absfile|/home/jane/my-project-dir/example3.ext|] ] pantry-0.9.3.2/app/test-pretty-exceptions/windows/System/Terminal.hs0000644000000000000000000000553714414332573023736 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | The module of this name differs as between Windows and non-Windows builds. -- This is the Windows version. module System.Terminal ( getTerminalWidth , hIsTerminalDeviceOrMinTTY ) where import Foreign.Marshal.Alloc ( allocaBytes ) import Foreign.Ptr ( Ptr ) import Foreign.Storable ( peekByteOff ) import RIO import RIO.Partial ( read ) import System.IO hiding ( hIsTerminalDevice ) import System.Process ( StdStream (..), createProcess, shell, std_err, std_in , std_out, waitForProcess ) import System.Win32 ( isMinTTYHandle, withHandleToHANDLE ) type HANDLE = Ptr () data CONSOLE_SCREEN_BUFFER_INFO sizeCONSOLE_SCREEN_BUFFER_INFO :: Int sizeCONSOLE_SCREEN_BUFFER_INFO = 22 posCONSOLE_SCREEN_BUFFER_INFO_srWindow :: Int posCONSOLE_SCREEN_BUFFER_INFO_srWindow = 10 -- 4 x Word16 Left,Top,Right,Bottom c_STD_OUTPUT_HANDLE :: Int c_STD_OUTPUT_HANDLE = -11 foreign import ccall unsafe "windows.h GetConsoleScreenBufferInfo" c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO Bool foreign import ccall unsafe "windows.h GetStdHandle" c_GetStdHandle :: Int -> IO HANDLE getTerminalWidth :: IO (Maybe Int) getTerminalWidth = do hdl <- c_GetStdHandle c_STD_OUTPUT_HANDLE allocaBytes sizeCONSOLE_SCREEN_BUFFER_INFO $ \p -> do b <- c_GetConsoleScreenBufferInfo hdl p if not b then do -- This could happen on Cygwin or MSYS let stty = (shell "stty size") { std_in = UseHandle stdin , std_out = CreatePipe , std_err = CreatePipe } (_, mbStdout, _, rStty) <- createProcess stty exStty <- waitForProcess rStty case exStty of ExitFailure _ -> pure Nothing ExitSuccess -> maybe (pure Nothing) (\hSize -> do sizeStr <- hGetContents hSize case map read $ words sizeStr :: [Int] of [_r, c] -> pure $ Just c _ -> pure Nothing ) mbStdout else do [left,_top,right,_bottom] <- forM [0..3] $ \i -> do v <- peekByteOff p (i * 2 + posCONSOLE_SCREEN_BUFFER_INFO_srWindow) pure $ fromIntegral (v :: Word16) pure $ Just (1 + right - left) -- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal -- devices, but isMinTTYHandle does. hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool hIsTerminalDeviceOrMinTTY h = do isTD <- hIsTerminalDevice h if isTD then pure True else liftIO $ withHandleToHANDLE h isMinTTYHandle pantry-0.9.3.2/app/test-pretty-exceptions/unix/System/Terminal.hsc0000644000000000000000000000263114446516353023367 0ustar0000000000000000{-# LANGUAGE CApiFFI #-} -- | The module of this name differs as between Windows and non-Windows builds. -- This is the non-Windows version. module System.Terminal ( getTerminalWidth , hIsTerminalDeviceOrMinTTY ) where import Foreign import Foreign.C.Types import RIO (MonadIO, Handle, hIsTerminalDevice) #include #include newtype WindowWidth = WindowWidth CUShort deriving (Eq, Ord, Show) instance Storable WindowWidth where sizeOf _ = (#size struct winsize) alignment _ = (#alignment struct winsize) peek p = WindowWidth <$> (#peek struct winsize, ws_col) p poke p (WindowWidth w) = do (#poke struct winsize, ws_col) p w -- `ioctl` is variadic, so `capi` is needed, see: -- https://www.haskell.org/ghc/blog/20210709-capi-usage.html foreign import capi "sys/ioctl.h ioctl" ioctl :: CInt -> CInt -> Ptr WindowWidth -> IO CInt getTerminalWidth :: IO (Maybe Int) getTerminalWidth = alloca $ \p -> do errno <- ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) p if errno < 0 then pure Nothing else do WindowWidth w <- peek p pure . Just . fromIntegral $ w -- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal -- devices, but isMinTTYHandle does. hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool hIsTerminalDeviceOrMinTTY = hIsTerminalDevice pantry-0.9.3.2/test/Spec.hs0000644000000000000000000000005514302665443013602 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} pantry-0.9.3.2/test/Pantry/ArchiveSpec.hs0000644000000000000000000000720314446516353016367 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Pantry.ArchiveSpec ( spec ) where import Data.Maybe ( fromJust ) import Pantry import Path.IO ( resolveFile' ) import RIO import RIO.Text as T import Test.Hspec data TestLocation = TLFilePath String | TLUrl Text data TestArchive = TestArchive { testLocation :: !TestLocation , testSubdir :: !Text } getRawPackageLocationIdent' :: TestArchive -> IO PackageIdentifier getRawPackageLocationIdent' TestArchive{..} = do testLocation' <- case testLocation of TLFilePath relPath -> do absPath <- resolveFile' relPath pure $ ALFilePath $ ResolvedPath { resolvedRelative = RelFilePath $ fromString relPath , resolvedAbsolute = absPath } TLUrl url -> pure $ ALUrl url let archive = RawArchive { raLocation = testLocation' , raHash = Nothing , raSize = Nothing , raSubdir = testSubdir } runPantryApp $ getRawPackageLocationIdent $ RPLIArchive archive metadata where metadata = RawPackageMetadata { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing } parsePackageIdentifier' :: String -> PackageIdentifier parsePackageIdentifier' = fromJust . parsePackageIdentifier urlToStackCommit :: Text -> TestLocation urlToStackCommit commit = TLUrl $ T.concat [ "https://github.com/commercialhaskell/stack/archive/" , commit , ".tar.gz" ] treeWithoutCabalFile :: Selector PantryException treeWithoutCabalFile (TreeWithoutCabalFile _) = True treeWithoutCabalFile _ = False spec :: Spec spec = do it "finds cabal file from tarball" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" , testSubdir = "" } ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" it "finds cabal file from tarball with subdir '.'" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" , testSubdir = "." } ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" it "finds cabal file from tarball with a package.yaml" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" , testSubdir = "" } ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" it "finds cabal file from tarball with subdir '.' with a package.yaml" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" , testSubdir = "." } ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" it "finds cabal file from tarball with subdir 'subs/pantry/'" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" , testSubdir = "subs/pantry/" } ident `shouldBe` parsePackageIdentifier' "pantry-0.1.0.0" it "matches whole directory name" $ getRawPackageLocationIdent' TestArchive { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" , testSubdir = "subs/pant" } `shouldThrow` treeWithoutCabalFile it "follows symlinks to directories" $ do ident <- getRawPackageLocationIdent' TestArchive { testLocation = TLFilePath "attic/symlink-to-dir.tar.gz" , testSubdir = "symlink" } ident `shouldBe` parsePackageIdentifier' "foo-1.2.3" pantry-0.9.3.2/test/Pantry/BuildPlanSpec.hs0000644000000000000000000001021714520750057016651 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.BuildPlanSpec where import Data.Aeson.WarningParser ( WithJSONWarnings(..) ) import qualified Data.ByteString.Char8 as S8 import Data.Yaml ( decodeThrow ) import Pantry import RIO import Test.Hspec spec :: Spec spec = describe "PackageLocation" $ do describe "Archive" $ do describe "github" $ do let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) decode' = decodeThrow decode'' :: HasCallStack => ByteString -> IO (NonEmpty RawPackageLocationImmutable) decode'' bs = do WithJSONWarnings unresolved warnings <- decode' bs unless (null warnings) $ error $ show warnings resolvePaths Nothing unresolved it "'github' and 'commit' keys" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: oink/town" , "commit: abc123" ]) let expected :: RawPackageLocationImmutable expected = RPLIArchive RawArchive { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" , raHash = Nothing , raSize = Nothing , raSubdir = "" } RawPackageMetadata { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing } actual <- decode'' contents actual `shouldBe` pure expected it "'github', 'commit', and 'subdirs' keys" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: oink/town" , "commit: abc123" , "subdirs:" , " - foo" ]) let expected :: RawPackageLocationImmutable expected = RPLIArchive RawArchive { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" , raHash = Nothing , raSize = Nothing , raSubdir = "foo" } RawPackageMetadata { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing } actual <- decode'' contents actual `shouldBe` pure expected it "does not parse GitHub repo with no slash" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: oink" , "commit: abc123" ]) void (decode' contents) `shouldBe` Nothing it "does not parse GitHub repo with leading slash" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: /oink" , "commit: abc123" ]) void (decode' contents) `shouldBe` Nothing it "does not parse GitHub repo with trailing slash" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: oink/" , "commit: abc123" ]) void (decode' contents) `shouldBe` Nothing it "does not parse GitHub repo with more than one slash" $ do let contents :: ByteString contents = S8.pack (unlines [ "github: oink/town/here" , "commit: abc123" ]) void (decode' contents) `shouldBe` Nothing pantry-0.9.3.2/test/Pantry/CabalSpec.hs0000644000000000000000000000732314520750057016005 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.CabalSpec ( spec ) where import Distribution.Types.PackageName ( mkPackageName ) import Distribution.Types.Version ( mkVersion ) import Pantry import qualified Pantry.SHA256 as SHA256 import RIO import Test.Hspec spec :: Spec spec = describe "wrong cabal file" $ do let test :: HasCallStack => String -> RIO PantryApp () -> Spec test name action = it name (runPantryApp action :: IO ()) shouldThrow' x y = withRunInIO $ \run -> run x `shouldThrow` y test "Hackage" $ do sha <- either throwIO pure $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" let rpli = RPLIHackage (PackageIdentifierRevision name version3 (CFIHash sha (Just size))) Nothing go = loadCabalFileRawImmutable rpli name = mkPackageName "acme-missiles" version2 = mkVersion [0, 2] version3 = mkVersion [0, 3] size = FileSize 597 go `shouldThrow'` \case MismatchedPackageMetadata rpli' rpm _tree ident -> rpli == rpli' && rpm == RawPackageMetadata { rpmName = Just name , rpmVersion = Just version3 , rpmTreeKey = Nothing } && ident == PackageIdentifier name version2 _ -> False test "tarball with wrong ident" $ do archiveHash' <- either throwIO pure $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" let rpli = RPLIArchive archive rpm archive = RawArchive { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" , raHash = Just archiveHash' , raSize = Just $ FileSize 309199 , raSubdir = "yesod-auth" } rpm = RawPackageMetadata { rpmName = Just acmeMissiles , rpmVersion = Just version2 , rpmTreeKey = Nothing } go = loadCabalFileRawImmutable rpli acmeMissiles = mkPackageName "acme-missiles" version2 = mkVersion [0, 2] go `shouldThrow'` \case MismatchedPackageMetadata rpli' rpm' _treeKey ident -> rpli == rpli' && rpm == rpm' && ident == PackageIdentifier (mkPackageName "yesod-auth") (mkVersion [1, 6, 4, 1]) _ -> False test "tarball with wrong cabal file" $ do let rpli = RPLIArchive archive rpm archive = RawArchive { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" , raHash = either impureThrow Just $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" , raSize = Just $ FileSize 309199 , raSubdir = "yesod-auth" } rpm = RawPackageMetadata { rpmName = Just yesodAuth , rpmVersion = Just badVersion , rpmTreeKey = Nothing } go = loadCabalFileRawImmutable rpli yesodAuth = mkPackageName "yesod-auth" version = mkVersion [1, 6, 4, 1] badVersion = mkVersion [1, 6, 4, 0] go `shouldThrow'` \case MismatchedPackageMetadata rpli' rpm' _treeKey ident -> rpli == rpli' && rpm == rpm' && ident == PackageIdentifier yesodAuth version _ -> False pantry-0.9.3.2/test/Pantry/CasaSpec.hs0000644000000000000000000000536514520750057015656 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Pantry.CasaSpec ( spec ) where import Distribution.Types.Version ( mkVersion ) import Pantry import Pantry.SHA256 import Test.Hspec spec :: Spec spec = do loadHackagePackageSpec completeSpec completeSpec :: Spec completeSpec = it "completePackageLocation: unliftio_0_2_12" (shouldReturn (runPantryAppClean (cplComplete <$> completePackageLocation (argsRlpi unliftio_0_2_12))) ( PLIHackage (PackageIdentifier { pkgName = "unliftio" , pkgVersion = mkVersion [0, 2, 12] }) (argsCabalKey unliftio_0_2_12) (argsTreeKey unliftio_0_2_12))) loadHackagePackageSpec :: Spec loadHackagePackageSpec = do it "loadPackageRaw Exact hackage lookup" (shouldReturn (fmap packageTreeKey (runPantryAppClean (loadPackageRaw (argsRlpi unliftio_0_2_12)))) (argsTreeKey unliftio_0_2_12)) it "loadHackagePackageRaw Exact hackage lookup" (shouldReturn (fmap packageTreeKey (runPantryAppClean (loadPackageRaw (argsRlpi unliftio_0_2_12)))) (argsTreeKey unliftio_0_2_12)) it "loadHackagePackageRawViaCasa Exact hackage lookup" (shouldReturn (fmap (fmap packageTreeKey) (runPantryAppClean (tryLoadPackageRawViaCasa (argsRlpi unliftio_0_2_12) (argsTreeKey unliftio_0_2_12)))) (Just (argsTreeKey unliftio_0_2_12))) data Args = Args { argsRlpi :: !RawPackageLocationImmutable , argsTreeKey :: !TreeKey , argsRevision :: !PackageIdentifierRevision , argsCabalKey :: !BlobKey } unliftio_0_2_12 :: Args unliftio_0_2_12 = let cabalHash = either (error . show) id (fromHexText "b089fbc2ff2628a963c2c4b12143f2020874e3e5144ffd6c62b25639a0ca1483") cabalLen = FileSize 3325 cabalFileHash = CFIHash cabalHash (Just cabalLen) casaTreeKey = TreeKey (BlobKey (either (error . show) id (fromHexText "4971b43f3d473eff868eb1a0c359729b49f1779e78c462ba45ef0d1eda677699")) (FileSize 2229)) pir = PackageIdentifierRevision "unliftio" (mkVersion [0, 2, 12]) cabalFileHash in Args { argsRevision = pir , argsRlpi = RPLIHackage pir (Just casaTreeKey) , argsTreeKey = casaTreeKey , argsCabalKey = BlobKey cabalHash cabalLen } pantry-0.9.3.2/test/Pantry/FileSpec.hs0000644000000000000000000000105714446516353015666 0ustar0000000000000000module Pantry.FileSpec ( spec ) where import Control.Monad ( void ) import Pantry import Path import Path.IO import Test.Hspec spec :: Spec spec = describe "loadCabalFilePath" $ do it "sanity" $ do abs' <- resolveDir' "." (f, name, cabalfp) <- runPantryApp $ loadCabalFilePath Nothing abs' suffix <- parseRelFile "pantry.cabal" cabalfp `shouldBe` abs' suffix name' <- parsePackageNameThrowing "pantry" name `shouldBe` name' void $ f NoPrintWarnings pantry-0.9.3.2/test/Pantry/GlobalHintsSpec.hs0000644000000000000000000000354214454740300017204 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.GlobalHintsSpec ( spec ) where import Distribution.Types.PackageName ( mkPackageName ) import Distribution.Version ( mkVersion ) import Pantry ( WantedCompiler (..), loadGlobalHints, runPantryAppClean ) import Pantry.Types ( getGlobalHintsFile ) import Path ( toFilePath ) import RIO import qualified RIO.Map as Map import Test.Hspec spec :: Spec spec = do let it' name inner = it name $ example $ runPantryAppClean $ do file <- getGlobalHintsFile writeFileBinary (toFilePath file) "this should be ignored" inner it' "unknown compiler" $ do mmap <- loadGlobalHints $ WCGhc (mkVersion [0, 0, 0, 0, 0, 0, 0]) liftIO $ mmap `shouldBe` Nothing it' "known compiler" $ do mmap <- loadGlobalHints $ WCGhc (mkVersion [8, 4, 3]) case mmap of Nothing -> error "not found" Just m -> liftIO $ do Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [8, 4, 3]) Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 11, 1, 0]) Map.lookup (mkPackageName "bytestring") m `shouldBe` Just (mkVersion [0, 10, 8, 2]) Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing it' "older known compiler" $ do mmap <- loadGlobalHints $ WCGhc (mkVersion [7, 8, 4]) case mmap of Nothing -> error "not found" Just m -> liftIO $ do Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [7, 8, 4]) Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 7, 0, 2]) Map.lookup (mkPackageName "Cabal") m `shouldBe` Just (mkVersion [1, 18, 1, 5]) Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing pantry-0.9.3.2/test/Pantry/HackageSpec.hs0000644000000000000000000000162714520750057016327 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.HackageSpec ( spec ) where import Distribution.Types.Version ( mkVersion ) import Pantry import RIO import Test.Hspec spec :: Spec spec = do it "update works" $ asIO $ void $ runPantryApp $ updateHackageIndex Nothing it "fuzzy lookup kicks in" $ do let pir = PackageIdentifierRevision "thisisnot-tobe-foundon-hackage-please" (mkVersion [1..3]) CFILatest runPantryApp (loadPackageRaw (RPLIHackage pir Nothing)) `shouldThrow` \case UnknownHackagePackage pir' _ -> pir == pir' _ -> False -- Flaky test, can be broken by new packages on Hackage. it "finds acme-missiles" $ do x <- runPantryApp (getHackageTypoCorrections "acme-missile") x `shouldSatisfy` ("acme-missiles" `elem`) pantry-0.9.3.2/test/Pantry/InternalSpec.hs0000644000000000000000000000505114454740300016547 0ustar0000000000000000module Pantry.InternalSpec ( spec ) where import Pantry ( runPantryApp ) import Pantry.HPack ( hpackVersion ) import Pantry.Internal ( makeTarRelative, normalizeParents ) import Test.Hspec spec :: Spec spec = do describe "normalizeParents" $ do let (!) :: HasCallStack => String -> Maybe String -> Spec input ! output = it input $ let x = normalizeParents input y = either (const Nothing) Just x in y `shouldBe` output "/file/\\test" ! Nothing "file/\\test" ! Just "file/\\test" "/file/////\\test" ! Nothing "file/////\\test" ! Just "file/\\test" "file/test/" ! Just "file/test" "/file/\\test////" ! Nothing "/file/./test" ! Nothing "file/./test" ! Just "file/test" "/test/file/../bob/fred/" ! Nothing "/test/file/../bob/fred" ! Nothing "test/file/../bob/fred/" ! Just "test/bob/fred" "test/file/../bob/fred" ! Just "test/bob/fred" "test0/test1/file/../../bob/fred" ! Just "test0/bob/fred" "../bob/fred" ! Nothing "../bob/fred/" ! Nothing "./bob/fred/" ! Just "bob/fred" "./bob/fred" ! Just "bob/fred" "./" ! Nothing "./." ! Nothing "/./" ! Nothing "/" ! Nothing "bob/fred/." ! Nothing "//home" ! Nothing "foobarbaz\\bin" ! Just "foobarbaz\\bin" describe "makeTarRelative" $ do let test :: HasCallStack => FilePath -> FilePath -> Maybe FilePath -> Spec test base rel expected = it (show (base, rel)) $ either (const Nothing) Just (makeTarRelative base rel) `shouldBe` expected test "foo/bar" "baz" $ Just "foo/baz" test "foo" "bar" $ Just "bar" test "foo" "/bar" Nothing test "foo/" "bar" Nothing -- MSS 2018-08-23: Arguable whether this should be Nothing -- instead, since we don't want any absolute paths. However, -- that's really a concern for normalizeParents. Point being: if -- you refactor in the future, and this turns into Nothing, that's -- fine. test "/foo" "bar" $ Just "/bar" describe "Parse HPack version" $ do {- let isVersion :: Version -> Bool isVersion _ = True -} it "Shipped hpack version" $ example $ do _version <- runPantryApp hpackVersion -- version `shouldSatisfy` isVersion pure () -- it "External hpack version" $ do -- version <- runPantryApp $ customHpack "/home/sibi/.local/bin/hpack" hpackVersion -- version `shouldSatisfy` isVersion pantry-0.9.3.2/test/Pantry/TreeSpec.hs0000644000000000000000000000577714446516353015723 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} module Pantry.TreeSpec ( spec ) where import Distribution.Types.PackageName ( mkPackageName ) import Distribution.Types.Version ( mkVersion ) import Pantry import qualified Pantry.SHA256 as SHA256 import RIO import Test.Hspec spec :: Spec spec = do let tarURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.tar.gz" zipURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.zip" emptyPM = RawPackageMetadata { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing } mkArchive url = RPLIArchive RawArchive { raLocation = ALUrl url , raHash = Nothing , raSize = Nothing , raSubdir = "" } emptyPM tarPL = mkArchive tarURL zipPL = mkArchive zipURL gitPL = RPLIRepo Repo { repoUrl = "https://github.com/snoyberg/file-embed.git" , repoCommit = "47b499c3c58ca465c56ee0295d0a76782a66751d" , repoType = RepoGit , repoSubdir = "" } emptyPM hgPL = RPLIRepo Repo { repoUrl = "https://bitbucket.org/snoyberg/file-embed" , repoCommit = "6d8126e7a4821788a0275fa7c2c4a0083e14d690" , repoType = RepoHg , repoSubdir = "" } emptyPM it "zip and tar.gz archives match" $ asIO $ runPantryAppClean $ do pair1 <- loadPackageRaw tarPL pair2 <- loadPackageRaw zipPL liftIO $ pair2 `shouldBe` pair1 it "archive and Git repo match" $ asIO $ runPantryAppClean $ do pair1 <- loadPackageRaw tarPL pair2 <- loadPackageRaw gitPL liftIO $ pair2 `shouldBe` pair1 -- https://github.com/commercialhaskell/pantry/issues/26 xit "archive and Hg repo match" $ asIO $ runPantryAppClean $ do pair1 <- loadPackageRaw tarPL pair2 <- loadPackageRaw hgPL liftIO $ pair2 `shouldBe` pair1 it "5045 no cabal file" $ asIO $ runPantryAppClean $ do let rpli = RPLIArchive archive rpm packageName = mkPackageName "yaml" version = mkVersion [0, 11, 1, 2] archive = RawArchive { raLocation = ALUrl "https://github.com/snoyberg/yaml/archive/yaml-0.11.1.2.tar.gz" , raHash = either impureThrow Just $ SHA256.fromHexBytes "b8564e99c555e670ee487bbf92d03800d955f0e6e16333610ef46534548e0a3d" , raSize = Just $ FileSize 94198 , raSubdir = "yaml" } rpm = RawPackageMetadata { rpmName = Just packageName , rpmVersion = Just version , rpmTreeKey = Nothing } void $ loadCabalFileRawImmutable rpli pantry-0.9.3.2/test/Pantry/TypesSpec.hs0000644000000000000000000002120314557754755016123 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Pantry.TypesSpec ( 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 ) import Distribution.Types.Version ( mkVersion ) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Pantry 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 (..), fromGregorian ) import Test.Hspec import Text.RawString.QQ hh :: HasCallStack => String -> Property -> Spec hh name p = it name $ do result <- check p unless result $ throwString "Hedgehog property failed" :: IO () genBlobKey :: Gen BlobKey genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> Gen.word (Range.linear 1 10000)) genSha256 :: Gen SHA256 genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500) samplePLIRepo :: ByteString samplePLIRepo = [r| subdir: wai cabal-file: # This is ignored, only included to make sure we get no warnings size: 1765 sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 name: wai version: 3.2.1.2 git: https://github.com/yesodweb/wai.git pantry-tree: size: 714 sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 |] samplePLIRepo2 :: ByteString samplePLIRepo2 = [r| name: merkle-log version: 0.1.0.0 git: https://github.com/kadena-io/merkle-log.git pantry-tree: size: 615 sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376 |] spec :: Spec spec = do describe "WantedCompiler" $ do hh "parse/render works" $ property $ do wc <- forAll $ let ghc = WCGhc <$> genVersion ghcjs = WCGhcjs <$> genVersion <*> genVersion genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100)) in Gen.choice [ghc, ghcjs] let text = utf8BuilderToText $ display wc case parseWantedCompiler text of Left e -> throwIO e Right actual -> liftIO $ actual `shouldBe` wc describe "Tree" $ do hh "parse/render works" $ property $ do tree <- forAll $ let sfp = do pieces <- Gen.list (Range.linear 1 10) sfpComponent let combined = T.intercalate "/" pieces case mkSafeFilePath combined of Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces Just sfp' -> pure sfp' sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum entry = TreeEntry <$> genBlobKey <*> Gen.choice (map pure [minBound..maxBound]) in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry) let bs = renderTree tree liftIO $ parseTree bs `shouldBe` Just tree describe "(Raw)SnapshotLayer" $ do let parseSl :: String -> IO RawSnapshotLayer parseSl str = case Yaml.decodeThrow . S8.pack $ str of (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x Nothing -> fail "Can't parse RawSnapshotLayer" it "parses snapshot using 'resolver'" $ do RawSnapshotLayer{..} <- parseSl $ "name: 'test'\n" ++ "resolver: lts-22.9\n" rslParent `shouldBe` RSLSynonym (LTS 22 9) it "parses snapshot using 'snapshot'" $ do RawSnapshotLayer{..} <- parseSl $ "name: 'test'\n" ++ "snapshot: lts-22.9\n" rslParent `shouldBe` RSLSynonym (LTS 22 9) it "throws if both 'resolver' and 'snapshot' are present" $ do let go = parseSl $ "name: 'test'\n" ++ "resolver: lts-22.9\n" ++ "snapshot: lts-22.9\n" go `shouldThrow` anyException it "throws if both 'snapshot' and 'compiler' are not present" $ do let go = parseSl "name: 'test'\n" go `shouldThrow` anyException it "works if no 'snapshot' specified" $ do RawSnapshotLayer{..} <- parseSl $ "name: 'test'\n" ++ "compiler: ghc-9.6.4\n" rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [9, 6, 4])) hh "rendering the name of an LTS to JSON" $ property $ do (major, minor) <- forAll $ (,) <$> Gen.integral (Range.linear 1 10000) <*> Gen.integral (Range.linear 1 10000) liftIO $ Yaml.toJSON (RSLSynonym $ LTS major minor) `shouldBe` Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor]) hh "rendering the name of a nightly to JSON" $ property $ do days <- forAll $ Gen.integral $ Range.linear 1 10000000 let day = ModifiedJulianDay days liftIO $ Yaml.toJSON (RSLSynonym $ Nightly day) `shouldBe` Yaml.String (T.pack $ "nightly-" ++ show day) it "FromJSON instance for PLIRepo" $ do WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo warnings `shouldBe` [] pli <- resolvePaths Nothing unresolvedPli let repoValue = Repo { repoSubdir = "wai" , repoType = RepoGit , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" , repoUrl = "https://github.com/yesodweb/wai.git" } pantrySha = SHA256.fromHexBytes "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2" psha <- case pantrySha of Right psha -> pure psha _ -> fail "Failed decoding sha256" let pkgValue = PackageMetadata { pmIdent = PackageIdentifier (mkPackageName "wai") (mkVersion [3, 2, 1, 2]) , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) } pli `shouldBe` PLIRepo repoValue pkgValue WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli warnings2 `shouldBe` [] reparsed' <- resolvePaths Nothing reparsed reparsed' `shouldBe` pli it "parseHackageText parses" $ do let txt = "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" hsha = SHA256.fromHexBytes "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" sha <- case hsha of Right sha' -> pure sha' _ -> fail "parseHackagetext: failed decoding the sha256" let Right (pkgIdentifier, blobKey) = parseHackageText txt blobKey `shouldBe` BlobKey sha (FileSize 5058) pkgIdentifier `shouldBe` PackageIdentifier (mkPackageName "persistent") (mkVersion [2, 8, 2]) it "roundtripping a PLIRepo" $ do WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2 warnings `shouldBe` [] pli <- resolvePaths Nothing unresolvedPli WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli warnings2 `shouldBe` [] pli2 <- resolvePaths Nothing unresolvedPli2 pli2 `shouldBe` (pli :: PackageLocationImmutable) describe "completeSnapshotLocation" $ do let sameUrl (SLUrl txt _) (RSLUrl txt' _) txt'' = do txt `shouldBe` txt' txt `shouldBe` txt'' sameUrl _ _ _ = liftIO $ error "Snapshot synonym did not complete as expected" it "default location for nightly-2024-02-04" $ do let sn = Nightly $ fromGregorian 2024 2 4 loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn sameUrl loc (defaultSnapshotLocation sn) "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2024/2/4.yaml" it "default location for lts-22.9" $ do let sn = LTS 22 9 loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn sameUrl loc (defaultSnapshotLocation sn) "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/9.yaml" pantry-0.9.3.2/CONTRIBUTING.md0000644000000000000000000002663314546317531013642 0ustar0000000000000000# Contributors Guide Thank you for considering contributing to the maintenance or development of pantry! We hope that the following information will encourage and assist you. We start with some advice about pantry's governance. ## pantry's governance People involved in maintaining or developing pantry with rights to make commits to the repository can be classified into two groups: 'committers' and 'maintainers'. ### pantry's committers We encourages a wide range of people to be granted rights to make commits to the repository. People are encouraged to take initiative to make non-controversial changes, such as documentation improvements, bug fixes, performance improvements, and feature enhancements. Maintainers should be included in discussions of controversial changes and tricky code changes. Our general approach is **"it's easier to ask forgiveness than permission"**. If there is ever a bad change, it can always be rolled back. ### pantry's maintainers pantry's maintainers are long-term contributors to the project. Michael Snoyman (@snoyberg) was the founder of pantry, and its initial maintainer - and he has added others. Michael's current interests and priorities mean that he is no longer actively involved in adding new features to pantry. Maintainers are recognized for their contributions including: * Direct code contribution * Review of pull requests * Interactions on the GitHub issue tracker The maintainer team make certain decisions when that is necessary, specifically: * How to proceed, if there is disagreement on how to do so on a specific topic * Whether to add or remove (see further below) a maintainer Generally, maintainers are only removed due to non-participation or actions unhealthy to the project. Removal due to non-participation is not a punishment, simply a recognition that maintainership is for active participants only. We hope that removal due to unhealthy actions will never be necessary, but would include protection for cases of: * Disruptive behavior in public channels related to pantry * Impairing the codebase through bad commits/merges Like committers, maintainers are broadly encouraged to make autonomous decisions. Each maintainer is empowered to make a unilateral decision. However, maintainers should favor getting consensus first if: * They are uncertain what is the best course of action * They anticipate that other maintainers or users of pantry will disagree on the decision ## Bug Reports Please [open an issue](https://github.com/commercialhaskell/pantry/issues/new) and use the provided template to include all necessary details. The more detailed your report, the faster it can be resolved and will ensure it is resolved in the right way. Once your bug has been resolved, the responsible person will tag the issue as _Needs confirmation_ and assign the issue back to you. Once you have tested and confirmed that the issue is resolved, close the issue. If you are not a member of the project, you will be asked for confirmation and we will close it. ## Error messages To support the Haskell Foundation's [Haskell Error Index](https://errors.haskell.org/) initiative, all pantry error messages generated by pantry itself should have a unique initial line: ~~~text Error: [S-nnn] ~~~ where `nnn` is a three-digit number in the range 100 to 999. If you create a new pantry error, select a number using a random number generator (see, for example, [RANDOM.ORG](https://www.random.org/)) and check that number is not already in use in pantry's code. If it is, pick another until the number is unique. All exceptions generated by pantry itself are implemented using data constructors of closed sum types. Typically, there is one such type for each module that exports functions that throw exceptions. ## Code If you would like to contribute code to fix a bug, add a new feature, or otherwise improve pantry, pull requests are most welcome. It's a good idea to [submit an issue](https://github.com/commercialhaskell/pantry/issues/new) to discuss the change before plowing into writing code. Please include a [ChangeLog](https://github.com/commercialhaskell/pantry/blob/master/ChangeLog.md) entry with your pull request. ## Code Quality The pantry project uses [yamllint](https://github.com/adrienverge/yamllint) as a YAML file quality tool and [HLint](https://github.com/ndmitchell/hlint) as a code quality tool. ### Linting of YAML files The yamllint configuration extends the tools default and is set out in `.yamllint.yaml`. In particular, indentation is set at 2 spaces and `- ` in sequences is treated as part of the indentation. ### Linting of Haskell source code The HLint configurations is set out in `.hlint.yaml`. pantry contributors need not follow dogmatically the suggested HLint hints but are encouraged to debate their usefulness. If you find a HLint hint is not useful and detracts from readability of code, consider marking it in the [configuration file](https://github.com/commercialhaskell/pantry/blob/master/.hlint.yaml) to be ignored. Please refer to the [HLint manual](https://github.com/ndmitchell/hlint#readme) for configuration syntax. We are optimizing for code clarity, not code concision or what HLint thinks. You can install HLint with Stack. You might want to install it in the global project in case you run into dependency conflicts. HLint can report hints in your favourite text editor. Refer to the HLint repository for more details. To install, command: ~~~text stack install hlint ~~~ ## Code Style A single code style is not applied consistently to pantry's code and pantry is not Procrustean about matters of style. Rules of thumb, however, are: * keep pull requests that simply reformat code separate from those that make other changes to code; and * when making changes to code other than reformatting, follow the existing style of the function(s) or module(s) in question. That said, the following may help: * pantry's code generally avoids the use of C preprocessor (CPP) directives. Windows and non-Windows code is separated in separate source code directories and distinguished in pantry's Cabal file. Multi-line strings are generally formatted on the assumption that GHC's `CPP` language pragma is not being used. * Language pragmas usually start with `NoImplictPrelude`, where applicable, and then all others are listed alphabetically. The closing `#-}` are aligned, for purely aesthetic reasons. * pantry is compiled with GHC's `-Wall` enabled, which includes `-Wtabs` (no tabs in source code). Most modules are based on two spaces (with one space for a `where`) for indentation but older and larger modules are still based on four spaces. * pantry's code and documentation tends to be based on lines of no more than 80 characters or, if longer, no longer than necessary. * pantry uses export lists. * pantry's imports are listed alphabetically. The module names are left aligned, with space left for `qualified` where it is absent. * pantry's code is sufficiently stable that explict import lists can sensibly be used. Not all modules have comprehensive explicit import lists. * Short explicit import lists follow the module name. Longer lists start on the line below the module name. Spaces are used to separate listed items from their enclosing parentheses. * In function type signatures, the `::` is kept on the same line as the function's name. This format is Haskell syntax highlighter-friendly. * If `where` is used, the declarations follow on a separate line. ## Continuous integration (CI) We use [GitHub Actions](https://docs.github.com/en/actions) to do CI on pantry. The configuration of the workflows is in the YAML files in `.github/workflows`. The current active workflows are: ### Linting - `lint.yml` This workflow will run if: * there is a pull request * commits are pushed to this branch: `master` The workflow has one job (`style`). It runs on `ubuntu` only and applies yamllint and Hlint. ### Stan tool - `stan.yml` [Stan](https://hackage.haskell.org/package/stan) is a Haskell static analysis tool. As of `stan-0.1.0.1`, it supports GHC >= 9.6.3. The tool is configured by the contents of the `.stan.toml` file. This workflow will run if: * there is a pull request * requested ## Haskell Language Server You may be using [Visual Studio Code](https://code.visualstudio.com/) (VS Code) with its [Haskell extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell), which is powered by the [Haskell Language Server](https://github.com/haskell/haskell-language-server) (HLS). pantry can be built with Stack (which is recommended) or with Cabal (the tool). === "Stack" If you use Stack to build Stack, command `stack ghci` in the root directory of the pantry project should work as expected, if you have first commanded `stack build` once. `ghc` should be on the PATH if you run VS Code itself in the Stack environment: ~~~text stack exec -- code . ~~~ The following [cradle (`hie.yaml`)](https://github.com/haskell/hie-bios) should suffice to configure Haskell Language Server (HLS) explicitly for each of the buildable components in pantry's Cabal file: ~~~yaml cradle: stack: - path: "./src" component: "pantry:lib" - path: "./int" component: "pantry:lib" - path: "./app" component: "pantry:exe:test-pretty-exceptions" - path: "./test" component: "pantry:test:spec" ~~~ === "Cabal (the tool)" If you use Cabal (the tool) to build Stack, command `cabal repl` in the root directory of the Stack project should work as expected, if you have GHC and (on Windows) MSYS2 on the PATH. `ghc` and (on Windows) MSYS2 should be on the PATH if you run commands (including `cabal`) in the Stack environment: ~~~text stack exec --no-ghc-package-path -- cabal repl ~~~ or ~~~text stack exec --no-ghc-package-path -- code . ~~~ Use of GHC's environment variable `GHC_PACKAGE_PATH` is not compatible with Cabal (the tool). That is why the `--no-ghc-package-path` flag must be specified with `stack exec` when relying on Cabal (the tool). The following [cradle (`hie.yaml`)](https://github.com/haskell/hie-bios) should suffice to configure Haskell Language Server (HLS) explicitly for each of the buildable components in pantry's Cabal file: ~~~yaml cradle: cabal: - path: "./src" component: "lib:pantry" - path: "./int" component: "lib:pantry" - path: "./app" component: "exe:test-pretty-exceptions" - path: "./test" component: "test:spec" ~~~ A cradle is not committed to pantry's repository because it imposes a choice of build tool. ## Slack channel If you're making deep changes and real-time communication with the pantry team would be helpful, we have a `#stack-collaborators` Slack channel in the Haskell Foundation workspace. To join the workspace, follow this [link](https://haskell-foundation.slack.com/join/shared_invite/zt-z45o9x38-8L55P27r12YO0YeEufcO2w#/shared-invite/email). ## Matrix room There is also a [Stack and Stackage room](https://matrix.to/#/#haskell-stack:matrix.org) at address `#haskell-stack:matrix.org` on [Matrix](https://matrix.org/). pantry-0.9.3.2/README.md0000644000000000000000000002266614302665443012670 0ustar0000000000000000# pantry [![Build Status](https://dev.azure.com/commercialhaskell/pantry/_apis/build/status/commercialhaskell.pantry?branchName=master)](https://dev.azure.com/commercialhaskell/pantry/_build/latest?definitionId=6&branchName=master) Content addressable Haskell package management, providing for secure, reproducible acquisition of Haskell package contents and metadata. ## What is Pantry * A Haskell library, storage specification, and network protocol * Intended for content-addressable storage of Haskell packages * Allows non-centralized package storage * Primarily for use by Stackage and Stack, hopefully other tools as well ## Goals * Efficient, distributed package storage for Haskell * Superset of existing storage mechanisms * Security via content addressable storage * Allow more Stackage-style snapshots to exist * Allow authors to bypass Hackage for uploads * Allow Stackage to create forks of packages on Hackage __TODO__ Content below needs to be updated. * Support for hpack in PackageLocationImmutable? ## Package definition Pantry defines the following concepts: * __Blob__: a raw byte sequence, identified by its key (SHA256 of the contents) * __Tree entry__: contents of a single file (identified by blob key) and whether or not it is executable. * NOTE: existing package formats like tarballs support more sophisticated options. We explicitly do not support those. If such functionality is needed, fallback to those mechanism is required. * __Tree__: mapping from relative path to a tree entry. Some basic sanity rules apply to the paths: no `.` or `..` directory components, no newlines in filepaths, does not begin with `/`, no `\\` (we normalize to POSIX-style paths). A tree is identified by a tree key (SHA256 of the tree's serialized format). * __Package__: a tree key for the package contents, package name, version number, and cabal file blob key. Requirements: there must be a single file with a `.cabal` file extension at the root of the tree, and it must match the cabal file blob key. The cabal file must be located at `pkgname.cabal`. Each tree can be in at most one package, and therefore tree keys work as package keys too. Note that with the above, a tree key is all the information necessary to uniquely identify a package. However, including additional information (package name, version, cabal key) in config files may be useful for optimizations or user friendliness. If such extra information is ever included, it must be validated to concur with the package contents itself. ### Package location Packages will optionally be sourced from some location: * __Hackage__ requires the package name, version number, and revision number. Each revision of a package will end up with a different tree key. * __Archive__ takes a URL pointing to a tarball (gzipped or not) or a ZIP file. An implicit assumption is that archives remain immutable over time. Use tree keys to verify this assumption. (Same applies to Hackage for that matter.) * __Repository__ takes a repo type (Git or Mercurial), URL, and commit. Assuming the veracity of the cryptographic hashes on the repos, this should guarantee a unique set of files. In order to deal with _megarepos_ (repos and archives containing more than one package), there is also a subdirectory for the archive and repository cases. An empty subdir `""` would be the case for a standard repo/archive. In order to meet the rules of a package listed above, the following logic is applied to all three types above: * Find all of the files in the raw location, and represent as `Map FilePath TreeEntry` (or equivalent). * Remove a wrapper directory. If _all_ filepaths in that `Map` are contained within the same directory, strip it from all of the paths. For example, if the paths are `foo/bar` and `foo/baz`, the paths will be reduced to `bar` and `baz`. * After this wrapper is removed, then subdirectory logic is applied, essentially applying `stripPrefix` to the filepaths. If the subdir is `yesod-bin` and files exist called `yesod-core/yesod-core.cabal` and `yesod-bin/yesod-bin.cabal`, the only file remaining after subdir stripping would be `yesod-bin.cabal`. Note that trailing slashes must be handled appropriately, and that an empty subdir string results in this step being a noop. The result of all of this is that, given one of the three package locations above, we can receive a tree key which will provide an installable package. That tree key will remain immutable. ### How tooling refers to packages We'll get to the caching mechanism for Pantry below. However, the recommended approach for tooling is to support some kind of composite of the Pantry keys, parsed info, and raw package location. This allows for more efficient lookups when available, with a fallback when mirrors don't have the needed information. An example: ```yaml extra-deps: - name: foobar version: 1.2.3.4 pantry: deadbeef # tree key cabal-file: 12345678 # blob key archive: https://example.com/foobar-1.2.3.4.tar.gz ``` It is also recommended that tooling provide an easy way to generate such complete information from, e.g., just the URL of the tarball, and that upon reading information, hashes, package names, and version numbers are all checked for correctness. ## Pantry caching One simplistic option for Pantry would be that, every time a piece of data is needed, Pantry downloads the necessary tarball/Git repo/etc. However, this would in practice be highly wasteful, since downloading Git repos and archives just to get a single cabal file (for plan construction purposes) is overkill. Instead, here's the basic idea for how caching works: * All data for Pantry can be stored in a SQL database. Local tools like Stack will use an SQLite database. Servers will use PostgreSQL. * We'll define a network protocol (initially just HTTP, maybe extending to something more efficient if desired) for querying blobs and trees. * When a blob or tree is needed, it is first checked for in the local SQLite cache. If it's not available there, a request to the Pantry mirrors (configurable) will be made for the data. Since everything is content addressable, it is safe to use untrusted mirrors. * If the data is not available in a mirror, and a location is provided, the location will be downloaded and cached locally. We may also allow these Pantry mirrors to provide some kind of query interface to find out, e.g., the latest version of a package on Hackage. That's still TBD. ## Example: resolving a package location To work through a full example, the following three stanzas are intended to have equivalent behavior: ```yaml - archive: https://example.com/foobar-1.2.3.4.tar.gz - name: foobar version: 1.2.3.4 pantry: deadbeef # tree key cabal-file: 12345678 # blob key archive: https://example.com/foobar-1.2.3.4.tar.gz - pantry: deadbeef ``` The question is: how does the first one (presumably what a user would want to enter) be resolved into the second and third? Pantry would follow this set of steps: * Download the tarball from the given URL * Place each file in the tarball into its store as a blob, getting a blob key for each. The tarball is now represented as `Map FilePath BlobKey` * Perform the root directory stripping step, removing a shared path * Since there's no subdirectory: no subdirectory stripping would be performed * Serialize the `Map FilePath BlobKey` to a binary format and take its hash to get a tree key * Store the tree in the store referenced by its tree key. In our example: the tree key is `deadbeef`. * Ensure that the tree is a valid package by checking for a single cabal file at the root. In our example, that's found in `foobar.cabal` with blob key `12345678`. * Parse the cabal file and ensure that it is a valid cabal file, and that its package name is `foobar`. Grab the version number (1.2.3.4). * We now know that tree key `deadbeef` is a valid package, and can refer to it by tree key exclusively. However, including the other information allows us to verify our assumptions, provide user-friendly readable data, and provide a fallback if the package isn't in the Pantry cache. ## More advanced content discovery There are three more advanced cases to consider: * Providing fall-back locations for content, such as out of concern for a single URL being removed in the future * Closed corporate setups, where access to the general internet may either be impossible or undesirable * Automatic discovery of missing content by hash The following extensions are possible to address these cases: * Instead of a single package location, provide a list of package locations with fallback semantics. * Corporate environments will be encouraged to run a local Pantry mirror, and configure clients like Stack to speak to these mirrors instead of the default ones (or in addition to). * Provide some kind of federation protocol for Pantry where servers can registry with each other and requests for content can be pinged to each other. Providing override at the client level for Pantry mirror locations is a __MUST__. Making it easy to run in a corporate environment is a __SHOULD__. Providing the fallback package locations seems easy enough that we should include it initially, but falls under a __SHOULD__. The federated protocol should be added on-demand. pantry-0.9.3.2/ChangeLog.md0000644000000000000000000001600714566666737013575 0ustar0000000000000000# Changelog for pantry ## v0.9.3.2 * Support `ansi-terminal-1.0.2`. * Bug fix: On Windows, `loadPackageRaw` supports repositories with submodules, as intended. ## v0.9.3.1 * Depend on `aeson-warning-parser-0.1.1`. ## v0.9.3 * Add error S-628 (`LocalNoArchiveFileFound`). * Depend on `rio-prettyprint-0.1.7.0`. ## v0.9.2 * `defaultCasaRepoPrefix` references https://casa.stackage.org, instead of https://casa.fpcomplete.com. * Depend on `crypton` instead of `cryptonite`. * Depend on `tar-conduit-0.4.0`, which will tolerate long filenames and directory names in archives created by `git archive`. ## v0.9.1 * Expose module `Pantry.SQLite`. ## 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. `NoCasaConfig` is now a data constructor of `PantryException`. * `withRepo`, in the case of Git, will now, if necessary, fetch the specific commit. (For example, GitHub repositories include the commits of unmerged pull requests but these are not fetched when the repository is cloned.) ## v0.8.2.2 * Add error S-395 (`NoLocalPackageDirFound`). ## v0.8.2.1 * On Windows, avoid fatal `tar: Cannot connect to C: resolve failed` bug when archiving repository submodules. ## v0.8.2 * `PantryException` is now an instance of the `Text.PrettyPrint.Leijen.Extended.Pretty` class (provided by the `rio-prettyprint` package). * Module `Pantry` now exports `FuzzyResults`, `Mismatch` and `SafeFilePath` (and `mkSafeFilePath`), used in data constructors of `PantryException`. ## v0.8.1 * Support `hpack-0.35.1`, and prettier `HpackLibraryException` error messages. ## v0.8.0 * `findOrGenerateCabalFile`, `loadCabalFilePath`, `loadCabalFile` and `loadCabalFileRaw` no longer assume that the program name used by Hpack (the library) is "stack", and take a new initial argument of type `Maybe Text` to specify the desired program name. The default is "hpack". ## v0.7.1 * 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. ## v0.7.0 * Change `defaultHackageSecurityConfig` such that field `hscIgnoreExpiry = True`, to be consistent with the defaults of the `WithJSONWarnings HackageSecurityConfig` instance of `FromJSON`. ## v0.6.0 * Rename `HackageSecurityConfig` as `PackageIndexConfig`, `defaultHackageSecurityConfig` as `defaultPackageIndexConfig`, and `pcHackageSecurity` field of `PantryConfig` as `pcPackageIndex`. * Expose new `HackageSecurityConfig` and `defaultHackageSecurityConfig`. The former represents Hackage Security configurations (only - no download prefix). * Change the data constructor of `PackageIndexConfig` to have fields for a download prefix (type `Text`) and of type `HackageSecurityConfig`. * The `WithJSONWarnings PackageIndexConfig` instance of `FromJSON` now assigns default value `defaultHackageSecurityConfig` if the `hackage-security` key is absent from the JSON object. * Expose `defaultDownloadPrefix`, for the official Hackage server. ## v0.5.7 * Expose `loadAndCompleteSnapshotRaw'` and `loadAndCompleteSnapshot'`, which allow the toggling of the debug output of the raw snapshot layer. See [#55](https://github.com/commercialhaskell/pantry/pull/55). * Support GHC 9.4. ## v0.5.6 * Remove operational and mirror keys from bootstrap key set. See [#53](https://github.com/commercialhaskell/pantry/pull/53). ## v0.5.5 * Support `Cabal-3.6.0.0`. ## v0.5.4 * Support `aeson-2.0.0.0`. ## v0.5.3 * improve and expose `fetchRepos`/`fetchReposRaw`. ## v0.5.2.3 * Support for GHC 9.0. See [#39](https://github.com/commercialhaskell/pantry/pull/39). ## v0.5.2.2 * Support for `Cabal-3.4.0.0`. See [#38](https://github.com/commercialhaskell/pantry/pull/38). ## v0.5.2.1 * Support `persistent-2.13.0.0`. See [#35](https://github.com/commercialhaskell/pantry/issues/35). ## v0.5.2 * Fall back to BSD tar when type cannot be detected. See [#33](https://github.com/commercialhaskell/pantry/issues/33). ## v0.5.1.5 * Switch back to `hackage.haskell.org`. See [#30](https://github.com/commercialhaskell/pantry/pull/30). * Pass through basic auth credentials specified in URLs. See [#32](https://github.com/commercialhaskell/pantry/pull/32). ## v0.5.1.4 * Allow building with `persistent-2.11.0.0`. See [#28](https://github.com/commercialhaskell/pantry/pull/28). ## v0.5.1.3 * Handle case where tree exists in cache by blobs are missing. See [#27](https://github.com/commercialhaskell/pantry/issues/27). ## v0.5.1.2 * Skip a test for issue [#26](https://github.com/commercialhaskell/pantry/issues/26). ## v0.5.1.1 * Fix to allow multiple relative path of symlink. ## v0.5.1.0 * Catch all exceptions from Casa calls and recover. ## v0.5.0.0 * Make the location of LTS/Nightly snapshots configurable. ## v0.4.0.1 * Removed errant log message. ## v0.4.0.0 * Add a deprecation warning when using a repo/archive without a Cabal file, see Stack issue [#5210](https://github.com/commercialhaskell/stack/issues/5210). * Do not include repo/archive dependencies which do not include Cabal files in lock files. * Remove some no longer used functions. ## v0.3.0.0 * Upgrade to `Cabal-3.0.0.0`. ## v0.2.0.0 Bug fixes: * Don't compare the hashes of Cabal files. Addresses bugs such as Stack issue [#5045](https://github.com/commercialhaskell/stack/issues/5045). Data type changes: removed the `pmCabal` and `rpmCabal` fields. ## v0.1.1.2 Bug fixes: * Module mapping insertions into the database are now atomic. Previously, if you SIGTERMed at the wrong time while running a script, you could end up with an inconsistent database state. ## v0.1.1.1 Other changes: * Support building with `persistent-template-2.7.0`. ## v0.1.1.0 **Changes since 0.1.0.0** Bug fixes: * Fix to allow dependencies on specific versions of local git repositories. See Stack pull request [#4862](https://github.com/commercialhaskell/stack/pull/4862). Behavior changes: * By default, do not perform expiry checks in Hackage Security. See Stack issue [#4928](https://github.com/commercialhaskell/stack/issues/4928). Other changes: * Rename `pantry-tmp` package back to `pantry`, now that we have gained maintainership (which had been used by someone else for a candidate-only test that made it look like the name was free but prevented uploading a real package). ## 0.1.0.0 * Initial release. pantry-0.9.3.2/attic/hpack-0.1.2.3.tar.gz0000644000000000000000000000026614302665443015517 0ustar0000000000000000\\ 0]{;sBoBRJ O Fع`|8vf%~S:I|I*usjZ{GC6y| n?SoS[e(:TR[-RKl$ѷu#D S(pantry-0.9.3.2/attic/package-0.1.2.3.tar.gz0000644000000000000000000000031514302665443016017 0ustar0000000000000000w#Z @a}yq;f(-:AoPWݬ g:K&'"=Ÿ{vTn/ɽX%y (?jIr:>҄ űbywGBzm|?K]y،xs۲I;QxoCST}zն)ѹ6ڦ^/\@H(pantry-0.9.3.2/attic/symlink-to-dir.tar.gz0000644000000000000000000000051014302665443016506 0ustar0000000000000000h^j0`{٘6P;(G@9GzvYZ9ktVގR3VKI<4(68AtOmǦ=){}k1ooH)k rg\K[=m,TkoR/4k܃?it_%K) ?XYO\䟨䯴qQJ6x=wmt89<UsyC.(pantry-0.9.3.2/LICENSE0000644000000000000000000000276114302734211012376 0ustar0000000000000000Copyright (c) 2015-2022, Stack contributors All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Stack nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. pantry-0.9.3.2/pantry.cabal0000644000000000000000000001652714566667147013730 0ustar0000000000000000cabal-version: 2.0 -- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: pantry version: 0.9.3.2 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: CONTRIBUTING.md 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.SQLite 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: -fwrite-ide-info -hiedir=.hie -Wall build-depends: Cabal >=3 && <3.11 , aeson , aeson-warning-parser >=0.1.1 , ansi-terminal , base >=4.13 && <5 , bytestring , casa-client >=0.0.2 , casa-types , companion , conduit , conduit-extra , containers , crypton , crypton-conduit , digest , filelock , generic-deriving , hackage-security , hpack >=0.35.3 , http-client , http-client-tls >=0.3.6.2 , http-conduit , http-download >=0.2.1.0 , 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 >=0.1.7.0 , static-bytes , tar-conduit >=0.4.1 , 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.Types other-modules: Paths_pantry autogen-modules: Paths_pantry hs-source-dirs: int/ ghc-options: -fwrite-ide-info -hiedir=.hie -Wall build-depends: Cabal >=3 && <3.11 , aeson , aeson-warning-parser >=0.1.1 , ansi-terminal , base >=4.13 && <5 , bytestring , casa-client >=0.0.2 , casa-types , companion , conduit , conduit-extra , containers , crypton , crypton-conduit , digest , filelock , generic-deriving , hackage-security , hpack >=0.35.3 , http-client , http-client-tls >=0.3.6.2 , http-conduit , http-download >=0.2.1.0 , http-types , memory , mtl , network-uri , path , path-io , persistent , persistent-sqlite >=2.9.3 , persistent-template , primitive , resourcet , rio , rio-orphans , rio-prettyprint >=0.1.7.0 , static-bytes , tar-conduit >=0.4.1 , 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: -fwrite-ide-info -hiedir=.hie -Wall build-depends: Cabal >=3 && <3.11 , aeson , aeson-warning-parser >=0.1.1 , ansi-terminal , base >=4.13 && <5 , bytestring , casa-client >=0.0.2 , casa-types , companion , conduit , conduit-extra , containers , crypton , crypton-conduit , digest , filelock , generic-deriving , hackage-security , hpack >=0.35.3 , http-client , http-client-tls >=0.3.6.2 , http-conduit , http-download >=0.2.1.0 , 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 >=0.1.7.0 , static-bytes , tar-conduit >=0.4.1 , 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: -fwrite-ide-info -hiedir=.hie -Wall build-tool-depends: hspec-discover:hspec-discover build-depends: Cabal >=3 && <3.11 , QuickCheck , aeson , aeson-warning-parser >=0.1.1 , ansi-terminal , base >=4.13 && <5 , bytestring , casa-client >=0.0.2 , casa-types , companion , conduit , conduit-extra , containers , crypton , crypton-conduit , digest , exceptions , filelock , generic-deriving , hackage-security , hedgehog , hpack >=0.35.3 , hspec , http-client , http-client-tls >=0.3.6.2 , http-conduit , http-download >=0.2.1.0 , 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 >=0.1.7.0 , static-bytes , tar-conduit >=0.4.1 , 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