pantry-0.9.3: src/Pantry.hs
{-# 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
-- <https://tech.fpcomplete.com/blog/storing-generated-cabal-files>
--
-- @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.
--
-- @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")