{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Pantry
(
PantryConfig
, PackageIndexConfig (..)
, HackageSecurityConfig (..)
, defaultPackageIndexConfig
, defaultDownloadPrefix
, defaultHackageSecurityConfig
, defaultCasaRepoPrefix
, defaultCasaMaxPerRequest
, defaultSnapshotLocation
, defaultGlobalHintsLocation
, HasPantryConfig (..)
, withPantryConfig
, withPantryConfig'
, HpackExecutable (..)
, PantryApp
, runPantryApp
, runPantryAppClean
, runPantryAppWith
, hpackExecutableL
, hpackForceL
, PantryException (..)
, Mismatch (..)
, FuzzyResults (..)
, PackageName
, Version
, FlagName
, PackageIdentifier (..)
, Hpack.Force (..)
, FileSize (..)
, RelFilePath (..)
, ResolvedPath (..)
, Unresolved
, SafeFilePath
, mkSafeFilePath
, SHA256
, TreeKey (..)
, BlobKey (..)
, RawPackageMetadata (..)
, PackageMetadata (..)
, Package (..)
, CabalFileInfo (..)
, Revision (..)
, PackageIdentifierRevision (..)
, UsePreferredVersions (..)
, RawArchive (..)
, Archive (..)
, ArchiveLocation (..)
, Repo (..)
, RepoType (..)
, SimpleRepo (..)
, withRepo
, fetchRepos
, fetchReposRaw
, RawPackageLocation (..)
, PackageLocation (..)
, toRawPL
, RawPackageLocationImmutable (..)
, PackageLocationImmutable (..)
, RawSnapshotLocation (..)
, SnapshotLocation (..)
, toRawSL
, RawSnapshot (..)
, Snapshot (..)
, RawSnapshotPackage (..)
, SnapshotPackage (..)
, RawSnapshotLayer (..)
, SnapshotLayer (..)
, toRawSnapshotLayer
, WantedCompiler (..)
, SnapName (..)
, snapshotLocation
, GlobalHintsLocation (..)
, resolvePaths
, loadPackageRaw
, tryLoadPackageRawViaCasa
, loadPackage
, loadRawSnapshotLayer
, loadSnapshotLayer
, loadSnapshot
, loadAndCompleteSnapshot
, loadAndCompleteSnapshot'
, loadAndCompleteSnapshotRaw
, loadAndCompleteSnapshotRaw'
, CompletedSL (..)
, CompletedPLI (..)
, addPackagesToSnapshot
, AddPackagesConfig (..)
, CompletePackageLocation (..)
, completePackageLocation
, completeSnapshotLocation
, warnMissingCabalFile
, parseWantedCompiler
, parseSnapName
, parseRawSnapshotLocation
, parsePackageIdentifierRevision
, parseHackageText
, parsePackageIdentifier
, parsePackageName
, parsePackageNameThrowing
, parseFlagName
, parseVersion
, parseVersionThrowing
, packageIdentifierString
, packageNameString
, flagNameString
, versionString
, moduleNameString
, CabalString (..)
, toCabalStringMap
, unCabalStringMap
, gpdPackageIdentifier
, gpdPackageName
, gpdVersion
, fetchPackages
, unpackPackageLocationRaw
, unpackPackageLocation
, getPackageLocationName
, getRawPackageLocationIdent
, packageLocationIdent
, packageLocationVersion
, getRawPackageLocationTreeKey
, getPackageLocationTreeKey
, loadCabalFileRaw
, loadCabalFile
, loadCabalFileRawImmutable
, loadCabalFileImmutable
, loadCabalFilePath
, findOrGenerateCabalFile
, PrintWarnings (..)
, updateHackageIndex
, DidUpdateOccur (..)
, RequireHackageIndex (..)
, hackageIndexTarballL
, getHackagePackageVersions
, getLatestHackageVersion
, getLatestHackageLocation
, getLatestHackageRevision
, getHackageTypoCorrections
, loadGlobalHints
, partitionReplacedDependencies
, 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 (..), GlobalHintsLocation (..)
, 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
, defaultGlobalHintsLocation, defaultHackageSecurityConfig
, defaultSnapshotLocation, flagNameString, getGlobalHintsFile
, globalHintsLocation, 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 ( copyFile, 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 (..), blankLine, flow, line, pretty, prettyDebugL
, prettyError, prettyInfoL, string
)
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)
hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b
hoistMaybe = MaybeT . pure
#endif
decodeYaml :: FilePath -> IO (Either String ([String], Value))
decodeYaml :: String -> IO (Either String ([String], Value))
decodeYaml String
file = do
(ParseException -> String)
-> (([Warning], Value) -> ([String], Value))
-> Either ParseException ([Warning], Value)
-> Either String ([String], Value)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ParseException -> String
forall e. Exception e => e -> String
displayException (([Warning] -> [String]) -> ([Warning], Value) -> ([String], Value)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Warning] -> [String]
formatWarnings) (Either ParseException ([Warning], Value)
-> Either String ([String], Value))
-> IO (Either ParseException ([Warning], Value))
-> IO (Either String ([String], Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either ParseException ([Warning], Value))
forall a.
FromJSON a =>
String -> IO (Either ParseException ([Warning], a))
decodeFileWithWarnings String
file
where
formatWarnings :: [Warning] -> [String]
formatWarnings = (Warning -> String) -> [Warning] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Warning -> String
formatWarning String
file)
formatYamlParseError :: FilePath -> Yaml.ParseException -> String
formatYamlParseError :: String -> ParseException -> String
formatYamlParseError String
file ParseException
e =
String
"In respect of an Hpack defaults file:\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
file
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":\n\n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseException -> String
forall e. Exception e => e -> String
displayException ParseException
e
withPantryConfig ::
HasLogFunc env
=> Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig :: forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig Path Abs Dir
root PackageIndexConfig
pic HpackExecutable
he Int
count CasaRepoPrefix
pullURL Int
maxPerRequest =
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig' Path Abs Dir
root PackageIndexConfig
pic HpackExecutable
he Force
Hpack.NoForce Int
count ((CasaRepoPrefix, Int) -> Maybe (CasaRepoPrefix, Int)
forall a. a -> Maybe a
Just (CasaRepoPrefix
pullURL, Int
maxPerRequest))
withPantryConfig'
:: HasLogFunc env
=> Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Hpack.Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig' :: forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig'
Path Abs Dir
root
PackageIndexConfig
pic
HpackExecutable
he
Force
hpackForce
Int
count
Maybe (CasaRepoPrefix, Int)
mCasaConfig
SnapName -> RawSnapshotLocation
snapLoc
WantedCompiler -> GlobalHintsLocation
globalHintsLoc
PantryConfig -> RIO env a
inner
= do
env
env <- RIO env env
forall r (m :: * -> *). MonadReader r m => m r
ask
Path Rel File
pantryRelFile <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
"pantry.sqlite3"
LogFunc -> RIO LogFunc a -> RIO env a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (LogFunc
forall a. Monoid a => a
mempty :: LogFunc) (RIO LogFunc a -> RIO env a) -> RIO LogFunc a -> RIO env a
forall a b. (a -> b) -> a -> b
$ Path Abs File -> (Storage -> RIO LogFunc a) -> RIO LogFunc a
forall env a.
HasLogFunc env =>
Path Abs File -> (Storage -> RIO env a) -> RIO env a
initStorage (Path Abs Dir
root Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
pantryRelFile) ((Storage -> RIO LogFunc a) -> RIO LogFunc a)
-> (Storage -> RIO LogFunc a) -> RIO LogFunc a
forall a b. (a -> b) -> a -> b
$ \Storage
storage -> env -> RIO env a -> RIO LogFunc a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO env
env (RIO env a -> RIO LogFunc a) -> RIO env a -> RIO LogFunc a
forall a b. (a -> b) -> a -> b
$ do
MVar Bool
ur <- Bool -> RIO env (MVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Bool
True
IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref1 <- Map RawPackageLocationImmutable GenericPackageDescription
-> RIO
env
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map RawPackageLocationImmutable GenericPackageDescription
forall a. Monoid a => a
mempty
IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
ref2 <- Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
-> RIO
env
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall a. Monoid a => a
mempty
PantryConfig -> RIO env a
inner PantryConfig
{ pcPackageIndex :: PackageIndexConfig
pcPackageIndex = PackageIndexConfig
pic
, pcHpackExecutable :: HpackExecutable
pcHpackExecutable = HpackExecutable
he
, pcHpackForce :: Force
pcHpackForce = Force
hpackForce
, pcRootDir :: Path Abs Dir
pcRootDir = Path Abs Dir
root
, pcStorage :: Storage
pcStorage = Storage
storage
, pcUpdateRef :: MVar Bool
pcUpdateRef = MVar Bool
ur
, pcConnectionCount :: Int
pcConnectionCount = Int
count
, pcParsedCabalFilesRawImmutable :: IORef (Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable = IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref1
, pcParsedCabalFilesMutable :: IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
pcParsedCabalFilesMutable = IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
ref2
, pcCasaConfig :: Maybe (CasaRepoPrefix, Int)
pcCasaConfig = Maybe (CasaRepoPrefix, Int)
mCasaConfig
, pcSnapshotLocation :: SnapName -> RawSnapshotLocation
pcSnapshotLocation = SnapName -> RawSnapshotLocation
snapLoc
, pcGlobalHintsLocation :: WantedCompiler -> GlobalHintsLocation
pcGlobalHintsLocation = WantedCompiler -> GlobalHintsLocation
globalHintsLoc
}
defaultCasaRepoPrefix :: CasaRepoPrefix
defaultCasaRepoPrefix :: CasaRepoPrefix
defaultCasaRepoPrefix = $(thParserCasaRepo "https://casa.stackage.org")
defaultCasaMaxPerRequest :: Int
defaultCasaMaxPerRequest :: Int
defaultCasaMaxPerRequest = Int
1280
defaultPackageIndexConfig :: PackageIndexConfig
defaultPackageIndexConfig :: PackageIndexConfig
defaultPackageIndexConfig = PackageIndexConfig
{ picDownloadPrefix :: Text
picDownloadPrefix = Text
defaultDownloadPrefix
, picHackageSecurityConfig :: HackageSecurityConfig
picHackageSecurityConfig = HackageSecurityConfig
defaultHackageSecurityConfig
}
defaultDownloadPrefix :: Text
defaultDownloadPrefix :: Text
defaultDownloadPrefix = Text
"https://hackage.haskell.org/"
getLatestHackageVersion ::
(HasPantryConfig env, HasLogFunc env)
=> RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageIdentifierRevision)
getLatestHackageVersion :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageIdentifierRevision)
getLatestHackageVersion RequireHackageIndex
req PackageName
name UsePreferredVersions
preferred =
(((((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey))
-> (Version, Map Revision BlobKey))
-> Maybe
((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey))
-> Maybe (Version, Map Revision BlobKey)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey))
-> (Version, Map Revision BlobKey)
forall a b. (a, b) -> a
fst (Maybe
((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey))
-> Maybe (Version, Map Revision BlobKey))
-> (Map Version (Map Revision BlobKey)
-> Maybe
((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey)))
-> Map Version (Map Revision BlobKey)
-> Maybe (Version, Map Revision BlobKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Version (Map Revision BlobKey)
-> Maybe
((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey) (Map Version (Map Revision BlobKey)
-> Maybe (Version, Map Revision BlobKey))
-> ((Version, Map Revision BlobKey)
-> Maybe PackageIdentifierRevision)
-> Map Version (Map Revision BlobKey)
-> Maybe PackageIdentifierRevision
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Version, Map Revision BlobKey) -> Maybe PackageIdentifierRevision
forall {k}.
(Version, Map k BlobKey) -> Maybe PackageIdentifierRevision
go) (Map Version (Map Revision BlobKey)
-> Maybe PackageIdentifierRevision)
-> RIO env (Map Version (Map Revision BlobKey))
-> RIO env (Maybe PackageIdentifierRevision)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
req UsePreferredVersions
preferred PackageName
name
where
go :: (Version, Map k BlobKey) -> Maybe PackageIdentifierRevision
go (Version
version, Map k BlobKey
m) = do
(k
_rev, BlobKey SHA256
sha FileSize
size) <- ((k, BlobKey), Map k BlobKey) -> (k, BlobKey)
forall a b. (a, b) -> a
fst (((k, BlobKey), Map k BlobKey) -> (k, BlobKey))
-> Maybe ((k, BlobKey), Map k BlobKey) -> Maybe (k, BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map k BlobKey -> Maybe ((k, BlobKey), Map k BlobKey)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map k BlobKey
m
PackageIdentifierRevision -> Maybe PackageIdentifierRevision
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifierRevision -> Maybe PackageIdentifierRevision)
-> PackageIdentifierRevision -> Maybe PackageIdentifierRevision
forall a b. (a -> b) -> a -> b
$ PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version (CabalFileInfo -> PackageIdentifierRevision)
-> CabalFileInfo -> PackageIdentifierRevision
forall a b. (a -> b) -> a -> b
$ SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (Maybe FileSize -> CabalFileInfo)
-> Maybe FileSize -> CabalFileInfo
forall a b. (a -> b) -> a -> b
$ FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size
getLatestHackageLocation ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation RequireHackageIndex
req PackageName
name UsePreferredVersions
preferred = do
Maybe (Version, Map Revision BlobKey)
mversion <-
(((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey))
-> (Version, Map Revision BlobKey))
-> Maybe
((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey))
-> Maybe (Version, Map Revision BlobKey)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey))
-> (Version, Map Revision BlobKey)
forall a b. (a, b) -> a
fst (Maybe
((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey))
-> Maybe (Version, Map Revision BlobKey))
-> (Map Version (Map Revision BlobKey)
-> Maybe
((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey)))
-> Map Version (Map Revision BlobKey)
-> Maybe (Version, Map Revision BlobKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Version (Map Revision BlobKey)
-> Maybe
((Version, Map Revision BlobKey),
Map Version (Map Revision BlobKey))
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey (Map Version (Map Revision BlobKey)
-> Maybe (Version, Map Revision BlobKey))
-> RIO env (Map Version (Map Revision BlobKey))
-> RIO env (Maybe (Version, Map Revision BlobKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
req UsePreferredVersions
preferred PackageName
name
let mVerCfKey :: Maybe (Version, BlobKey)
mVerCfKey = do
(Version
version, Map Revision BlobKey
revisions) <- Maybe (Version, Map Revision BlobKey)
mversion
(Revision
_rev, BlobKey
cfKey) <- ((Revision, BlobKey), Map Revision BlobKey) -> (Revision, BlobKey)
forall a b. (a, b) -> a
fst (((Revision, BlobKey), Map Revision BlobKey)
-> (Revision, BlobKey))
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
-> Maybe (Revision, BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Revision BlobKey
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map Revision BlobKey
revisions
(Version, BlobKey) -> Maybe (Version, BlobKey)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version
version, BlobKey
cfKey)
Maybe (Version, BlobKey)
-> ((Version, BlobKey) -> RIO env PackageLocationImmutable)
-> RIO env (Maybe PackageLocationImmutable)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Version, BlobKey)
mVerCfKey (((Version, BlobKey) -> RIO env PackageLocationImmutable)
-> RIO env (Maybe PackageLocationImmutable))
-> ((Version, BlobKey) -> RIO env PackageLocationImmutable)
-> RIO env (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ \(Version
version, cfKey :: BlobKey
cfKey@(BlobKey SHA256
sha FileSize
size)) -> do
let pir :: PackageIdentifierRevision
pir = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version (SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size))
TreeKey
treeKey' <- PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
PackageLocationImmutable -> RIO env PackageLocationImmutable
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageLocationImmutable -> RIO env PackageLocationImmutable)
-> PackageLocationImmutable -> RIO env PackageLocationImmutable
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey'
getLatestHackageRevision ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
req PackageName
name Version
version = do
Map Revision BlobKey
revisions <- RequireHackageIndex
-> PackageName -> Version -> RIO env (Map Revision BlobKey)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName -> Version -> RIO env (Map Revision BlobKey)
getHackagePackageVersionRevisions RequireHackageIndex
req PackageName
name Version
version
case ((Revision, BlobKey), Map Revision BlobKey) -> (Revision, BlobKey)
forall a b. (a, b) -> a
fst (((Revision, BlobKey), Map Revision BlobKey)
-> (Revision, BlobKey))
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
-> Maybe (Revision, BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Revision BlobKey
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
forall k a. Map k a -> Maybe ((k, a), Map k a)
Map.maxViewWithKey Map Revision BlobKey
revisions of
Maybe (Revision, BlobKey)
Nothing -> Maybe (Revision, BlobKey, TreeKey)
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Revision, BlobKey, TreeKey)
forall a. Maybe a
Nothing
Just (Revision
revision, cfKey :: BlobKey
cfKey@(BlobKey SHA256
sha FileSize
size)) -> do
let cfi :: CabalFileInfo
cfi = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)
TreeKey
treeKey' <- PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey (PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi)
Maybe (Revision, BlobKey, TreeKey)
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Revision, BlobKey, TreeKey)
-> RIO env (Maybe (Revision, BlobKey, TreeKey)))
-> Maybe (Revision, BlobKey, TreeKey)
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall a b. (a -> b) -> a -> b
$ (Revision, BlobKey, TreeKey) -> Maybe (Revision, BlobKey, TreeKey)
forall a. a -> Maybe a
Just (Revision
revision, BlobKey
cfKey, TreeKey
treeKey')
fetchTreeKeys ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> [RawPackageLocationImmutable]
-> RIO env ()
fetchTreeKeys :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys [RawPackageLocationImmutable]
treeKeys = do
[RawPackageLocationImmutable]
packageLocationsMissing :: [RawPackageLocationImmutable] <-
ReaderT SqlBackend (RIO env) [RawPackageLocationImmutable]
-> RIO env [RawPackageLocationImmutable]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
((RawPackageLocationImmutable -> ReaderT SqlBackend (RIO env) Bool)
-> [RawPackageLocationImmutable]
-> ReaderT SqlBackend (RIO env) [RawPackageLocationImmutable]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM
((Maybe (Entity Tree) -> Bool)
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
-> ReaderT SqlBackend (RIO env) Bool
forall a b.
(a -> b)
-> ReaderT SqlBackend (RIO env) a -> ReaderT SqlBackend (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Entity Tree) -> Bool
forall a. Maybe a -> Bool
isNothing (ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
-> ReaderT SqlBackend (RIO env) Bool)
-> (RawPackageLocationImmutable
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> RawPackageLocationImmutable
-> ReaderT SqlBackend (RIO env) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
-> (TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> Maybe TreeKey
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Entity Tree)
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Entity Tree)
forall a. Maybe a
Nothing) TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey (Maybe TreeKey
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)))
-> (RawPackageLocationImmutable -> Maybe TreeKey)
-> RawPackageLocationImmutable
-> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey)
[RawPackageLocationImmutable]
treeKeys)
UTCTime
pullTreeStart <- IO UTCTime -> RIO env UTCTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
Map TreeKey Tree
treeKeyBlobs :: Map TreeKey P.Tree <-
(SomeException -> RIO env (Map TreeKey Tree))
-> RIO env (Map TreeKey Tree) -> RIO env (Map TreeKey Tree)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (RIO env (Map TreeKey Tree)
-> SomeException -> RIO env (Map TreeKey Tree)
forall a b. a -> b -> a
const RIO env (Map TreeKey Tree)
forall a. Monoid a => a
mempty)
(([(TreeKey, Tree)] -> Map TreeKey Tree)
-> RIO env [(TreeKey, Tree)] -> RIO env (Map TreeKey Tree)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
[(TreeKey, Tree)] -> Map TreeKey Tree
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
(ReaderT SqlBackend (RIO env) [(TreeKey, Tree)]
-> RIO env [(TreeKey, Tree)]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
(ConduitT
()
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
[(TreeKey, Tree)]
-> ReaderT SqlBackend (RIO env) [(TreeKey, Tree)]
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
([BlobKey]
-> ConduitT
()
(BlobKey, ByteString)
(ResourceT (ReaderT SqlBackend (RIO env)))
()
forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
i
(BlobKey, ByteString)
(ResourceT (ReaderT SqlBackend (RIO env)))
()
casaBlobSource
((TreeKey -> BlobKey) -> [TreeKey] -> [BlobKey]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TreeKey -> BlobKey
unTreeKey ((RawPackageLocationImmutable -> Maybe TreeKey)
-> [RawPackageLocationImmutable] -> [TreeKey]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey [RawPackageLocationImmutable]
packageLocationsMissing)) ConduitT
()
(BlobKey, ByteString)
(ResourceT (ReaderT SqlBackend (RIO env)))
()
-> ConduitT
(BlobKey, ByteString)
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
[(TreeKey, Tree)]
-> ConduitT
()
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
[(TreeKey, Tree)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
((BlobKey, ByteString)
-> ResourceT (ReaderT SqlBackend (RIO env)) (TreeKey, Tree))
-> ConduitT
(BlobKey, ByteString)
(TreeKey, Tree)
(ResourceT (ReaderT SqlBackend (RIO env)))
()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (BlobKey, ByteString)
-> ResourceT (ReaderT SqlBackend (RIO env)) (TreeKey, Tree)
forall (m :: * -> *).
MonadThrow m =>
(BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM ConduitT
(BlobKey, ByteString)
(TreeKey, Tree)
(ResourceT (ReaderT SqlBackend (RIO env)))
()
-> ConduitT
(TreeKey, Tree)
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
[(TreeKey, Tree)]
-> ConduitT
(BlobKey, ByteString)
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
[(TreeKey, Tree)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
ConduitT
(TreeKey, Tree)
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
[(TreeKey, Tree)]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList))))
UTCTime
pullTreeEnd <- IO UTCTime -> RIO env UTCTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let pulledPackages :: [RawPackageLocationImmutable]
pulledPackages =
(TreeKey -> Maybe RawPackageLocationImmutable)
-> [TreeKey] -> [RawPackageLocationImmutable]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(\TreeKey
treeKey' ->
(RawPackageLocationImmutable -> Bool)
-> [RawPackageLocationImmutable]
-> Maybe RawPackageLocationImmutable
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find
((Maybe TreeKey -> Maybe TreeKey -> Bool
forall a. Eq a => a -> a -> Bool
== TreeKey -> Maybe TreeKey
forall a. a -> Maybe a
Just TreeKey
treeKey') (Maybe TreeKey -> Bool)
-> (RawPackageLocationImmutable -> Maybe TreeKey)
-> RawPackageLocationImmutable
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey)
[RawPackageLocationImmutable]
packageLocationsMissing)
(Map TreeKey Tree -> [TreeKey]
forall k a. Map k a -> [k]
Map.keys Map TreeKey Tree
treeKeyBlobs)
let uniqueFileBlobKeys :: Set BlobKey
uniqueFileBlobKeys :: Set BlobKey
uniqueFileBlobKeys =
(Tree -> Set BlobKey) -> Map TreeKey Tree -> Set BlobKey
forall m a. Monoid m => (a -> m) -> Map TreeKey a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
(\(P.TreeMap Map SafeFilePath TreeEntry
files) -> [BlobKey] -> Set BlobKey
forall a. Ord a => [a] -> Set a
Set.fromList ((TreeEntry -> BlobKey) -> [TreeEntry] -> [BlobKey]
forall a b. (a -> b) -> [a] -> [b]
map TreeEntry -> BlobKey
teBlob (Map SafeFilePath TreeEntry -> [TreeEntry]
forall a. Map SafeFilePath a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map SafeFilePath TreeEntry
files)))
Map TreeKey Tree
treeKeyBlobs
UTCTime
pullBlobStart <- IO UTCTime -> RIO env UTCTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
Maybe Int
mpulledBlobKeys :: Maybe Int <-
(SomeException -> RIO env (Maybe Int))
-> RIO env (Maybe Int) -> RIO env (Maybe Int)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (RIO env (Maybe Int) -> SomeException -> RIO env (Maybe Int)
forall a b. a -> b -> a
const (Maybe Int -> RIO env (Maybe Int)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing))
((Int -> Maybe Int) -> RIO env Int -> RIO env (Maybe Int)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Maybe Int
forall a. a -> Maybe a
Just (ReaderT SqlBackend (RIO env) Int -> RIO env Int
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage
(ConduitT () Void (ResourceT (ReaderT SqlBackend (RIO env))) Int
-> ReaderT SqlBackend (RIO env) Int
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
(Set BlobKey
-> ConduitT
()
(BlobKey, ByteString)
(ResourceT (ReaderT SqlBackend (RIO env)))
()
forall (f :: * -> *) env i.
(Foldable f, HasPantryConfig env, HasLogFunc env) =>
f BlobKey
-> ConduitT
i
(BlobKey, ByteString)
(ResourceT (ReaderT SqlBackend (RIO env)))
()
casaBlobSource Set BlobKey
uniqueFileBlobKeys ConduitT
()
(BlobKey, ByteString)
(ResourceT (ReaderT SqlBackend (RIO env)))
()
-> ConduitT
(BlobKey, ByteString)
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
Int
-> ConduitT () Void (ResourceT (ReaderT SqlBackend (RIO env))) Int
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ((BlobKey, ByteString) -> Int)
-> ConduitT
(BlobKey, ByteString)
Int
(ResourceT (ReaderT SqlBackend (RIO env)))
()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC (Int -> (BlobKey, ByteString) -> Int
forall a b. a -> b -> a
const Int
1) ConduitT
(BlobKey, ByteString)
Int
(ResourceT (ReaderT SqlBackend (RIO env)))
()
-> ConduitT Int Void (ResourceT (ReaderT SqlBackend (RIO env))) Int
-> ConduitT
(BlobKey, ByteString)
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
Int
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Int Void (ResourceT (ReaderT SqlBackend (RIO env))) Int
forall (m :: * -> *) a o. (Monad m, Num a) => ConduitT a o m a
sumC))))
Maybe Int -> (Int -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
mpulledBlobKeys ((Int -> RIO env ()) -> RIO env ())
-> (Int -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Int
pulledBlobKeys -> do
UTCTime
pullBlobEnd <- IO UTCTime -> RIO env UTCTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
(Utf8Builder
"Pulled from Casa: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
[Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
List.intersperse Utf8Builder
", " ((RawPackageLocationImmutable -> Utf8Builder)
-> [RawPackageLocationImmutable] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display [RawPackageLocationImmutable]
pulledPackages)) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (String -> Text
T.pack (NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
pullTreeEnd UTCTime
pullTreeStart))) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"), " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Int -> Utf8Builder -> Utf8Builder
plural Int
pulledBlobKeys Utf8Builder
"file" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (String -> Text
T.pack (NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
pullBlobEnd UTCTime
pullBlobStart))) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
")")
[RawPackageLocationImmutable]
-> (RawPackageLocationImmutable -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
[RawPackageLocationImmutable]
packageLocationsMissing
(\RawPackageLocationImmutable
rawPackageLocationImmutable ->
let mkey :: Maybe TreeKey
mkey = RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey RawPackageLocationImmutable
rawPackageLocationImmutable
in case Maybe TreeKey
mkey of
Maybe TreeKey
Nothing ->
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
(Utf8Builder
"Ignoring package with no tree key " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
", can't look in Casa for it.")
Just TreeKey
key ->
case TreeKey -> Map TreeKey Tree -> Maybe Tree
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TreeKey
key Map TreeKey Tree
treeKeyBlobs of
Maybe Tree
Nothing ->
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
(Utf8Builder
"Package key " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> TreeKey -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display TreeKey
key Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
") not returned from Casa.")
Just Tree
tree -> do
PackageIdentifier
identifier <-
RawPackageLocationImmutable -> RIO env PackageIdentifier
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent RawPackageLocationImmutable
rawPackageLocationImmutable
case RawPackageLocationImmutable -> Tree -> Maybe BuildFile
forall (m :: * -> *).
MonadThrow m =>
RawPackageLocationImmutable -> Tree -> m BuildFile
findCabalOrHpackFile RawPackageLocationImmutable
rawPackageLocationImmutable Tree
tree of
Just BuildFile
buildFile -> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Either LoadCachedTreeException CachedTree
ecachedTree <- Tree
-> ReaderT
SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
forall env.
Tree
-> ReaderT
SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree)
loadCachedTree Tree
tree
case Either LoadCachedTreeException CachedTree
ecachedTree of
Left LoadCachedTreeException
e ->
RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> ReaderT SqlBackend (RIO env) ())
-> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
(Utf8Builder
"Loading cached tree after download from Casa failed on " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
LoadCachedTreeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow LoadCachedTreeException
e)
Right CachedTree
cachedTree ->
ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> ReaderT SqlBackend (RIO env) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
storeTree
RawPackageLocationImmutable
rawPackageLocationImmutable
PackageIdentifier
identifier
CachedTree
cachedTree
BuildFile
buildFile
Maybe BuildFile
Nothing ->
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
(Utf8Builder
"Unable to find build file for package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rawPackageLocationImmutable))
where
unTreeKey :: TreeKey -> BlobKey
unTreeKey :: TreeKey -> BlobKey
unTreeKey (P.TreeKey BlobKey
blobKey) = BlobKey
blobKey
fetchPackages ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f)
=> f PackageLocationImmutable
-> RIO env ()
fetchPackages :: forall env (f :: * -> *).
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
Foldable f) =>
f PackageLocationImmutable -> RIO env ()
fetchPackages f PackageLocationImmutable
pls = do
[RawPackageLocationImmutable] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys ((PackageLocationImmutable -> RawPackageLocationImmutable)
-> [PackageLocationImmutable] -> [RawPackageLocationImmutable]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (f PackageLocationImmutable -> [PackageLocationImmutable]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f PackageLocationImmutable
pls))
((PackageIdentifierRevision, Maybe TreeKey) -> RIO env ())
-> [(PackageIdentifierRevision, Maybe TreeKey)] -> RIO env ()
forall (f :: * -> *) env a.
(Foldable f, HasPantryConfig env) =>
(a -> RIO env ()) -> f a -> RIO env ()
traverseConcurrently_ (RIO env HackageTarballResult -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env HackageTarballResult -> RIO env ())
-> ((PackageIdentifierRevision, Maybe TreeKey)
-> RIO env HackageTarballResult)
-> (PackageIdentifierRevision, Maybe TreeKey)
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult)
-> (PackageIdentifierRevision, Maybe TreeKey)
-> RIO env HackageTarballResult
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball) [(PackageIdentifierRevision, Maybe TreeKey)]
hackages
[(Archive, PackageMetadata)] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Archive, PackageMetadata)] -> RIO env ()
fetchArchives [(Archive, PackageMetadata)]
archives
[(Repo, PackageMetadata)] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[(Repo, PackageMetadata)] -> RIO env ()
fetchRepos [(Repo, PackageMetadata)]
repos
where
s :: a -> Endo [a]
s a
x = ([a] -> [a]) -> Endo [a]
forall a. (a -> a) -> Endo a
Endo (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
run :: Endo [a] -> [a]
run (Endo [a] -> [a]
f) = [a] -> [a]
f []
(Endo [(PackageIdentifierRevision, Maybe TreeKey)]
hackagesE, Endo [(Archive, PackageMetadata)]
archivesE, Endo [(Repo, PackageMetadata)]
reposE) = (PackageLocationImmutable
-> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)]))
-> f PackageLocationImmutable
-> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)])
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap PackageLocationImmutable
-> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)])
go f PackageLocationImmutable
pls
hackages :: [(PackageIdentifierRevision, Maybe TreeKey)]
hackages = Endo [(PackageIdentifierRevision, Maybe TreeKey)]
-> [(PackageIdentifierRevision, Maybe TreeKey)]
forall {a}. Endo [a] -> [a]
run Endo [(PackageIdentifierRevision, Maybe TreeKey)]
hackagesE
archives :: [(Archive, PackageMetadata)]
archives = Endo [(Archive, PackageMetadata)] -> [(Archive, PackageMetadata)]
forall {a}. Endo [a] -> [a]
run Endo [(Archive, PackageMetadata)]
archivesE
repos :: [(Repo, PackageMetadata)]
repos = Endo [(Repo, PackageMetadata)] -> [(Repo, PackageMetadata)]
forall {a}. Endo [a] -> [a]
run Endo [(Repo, PackageMetadata)]
reposE
go :: PackageLocationImmutable
-> (Endo [(PackageIdentifierRevision, Maybe TreeKey)],
Endo [(Archive, PackageMetadata)], Endo [(Repo, PackageMetadata)])
go (PLIHackage PackageIdentifier
ident BlobKey
cfHash TreeKey
tree) = ((PackageIdentifierRevision, Maybe TreeKey)
-> Endo [(PackageIdentifierRevision, Maybe TreeKey)]
forall {a}. a -> Endo [a]
s (PackageIdentifier -> BlobKey -> PackageIdentifierRevision
toPir PackageIdentifier
ident BlobKey
cfHash, TreeKey -> Maybe TreeKey
forall a. a -> Maybe a
Just TreeKey
tree), Endo [(Archive, PackageMetadata)]
forall a. Monoid a => a
mempty, Endo [(Repo, PackageMetadata)]
forall a. Monoid a => a
mempty)
go (PLIArchive Archive
archive PackageMetadata
pm) = (Endo [(PackageIdentifierRevision, Maybe TreeKey)]
forall a. Monoid a => a
mempty, (Archive, PackageMetadata) -> Endo [(Archive, PackageMetadata)]
forall {a}. a -> Endo [a]
s (Archive
archive, PackageMetadata
pm), Endo [(Repo, PackageMetadata)]
forall a. Monoid a => a
mempty)
go (PLIRepo Repo
repo PackageMetadata
pm) = (Endo [(PackageIdentifierRevision, Maybe TreeKey)]
forall a. Monoid a => a
mempty, Endo [(Archive, PackageMetadata)]
forall a. Monoid a => a
mempty, (Repo, PackageMetadata) -> Endo [(Repo, PackageMetadata)]
forall {a}. a -> Endo [a]
s (Repo
repo, PackageMetadata
pm))
toPir :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision
toPir (PackageIdentifier PackageName
name Version
ver) (BlobKey SHA256
sha FileSize
size) =
PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
ver (SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size))
unpackPackageLocationRaw ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Path Abs Dir
-> RawPackageLocationImmutable
-> RIO env ()
unpackPackageLocationRaw :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RawPackageLocationImmutable -> RIO env ()
unpackPackageLocationRaw Path Abs Dir
fp RawPackageLocationImmutable
loc =
RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
loc RIO env Package -> (Package -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
unpackTree RawPackageLocationImmutable
loc Path Abs Dir
fp (Tree -> RIO env ()) -> (Package -> Tree) -> Package -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> Tree
packageTree
unpackPackageLocation ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Path Abs Dir
-> PackageLocationImmutable
-> RIO env ()
unpackPackageLocation :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> PackageLocationImmutable -> RIO env ()
unpackPackageLocation Path Abs Dir
fp PackageLocationImmutable
loc =
PackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env Package
loadPackage PackageLocationImmutable
loc RIO env Package -> (Package -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawPackageLocationImmutable -> Path Abs Dir -> Tree -> RIO env ()
unpackTree (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
loc) Path Abs Dir
fp (Tree -> RIO env ()) -> (Package -> Tree) -> Package -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> Tree
packageTree
loadCabalFileImmutable ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> PackageLocationImmutable
-> RIO env GenericPackageDescription
loadCabalFileImmutable :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
loc = RIO env GenericPackageDescription
-> RIO env GenericPackageDescription
forall {m :: * -> *} {s}.
(MonadReader s m, HasPantryConfig s, MonadIO m) =>
m GenericPackageDescription -> m GenericPackageDescription
withCache (RIO env GenericPackageDescription
-> RIO env GenericPackageDescription)
-> RIO env GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Parsing cabal file for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageLocationImmutable
loc
ByteString
bs <- PackageLocationImmutable -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env ByteString
loadCabalFileBytes PackageLocationImmutable
loc
([PWarning]
_warnings, GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> RIO env ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. a -> Either a b
Left (RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File))
-> RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
loc) ByteString
bs
let pm :: PackageMetadata
pm =
case PackageLocationImmutable
loc of
PLIHackage (PackageIdentifier PackageName
name Version
version) BlobKey
_cfHash TreeKey
mtree -> PackageMetadata
{ pmIdent :: PackageIdentifier
pmIdent = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
, pmTreeKey :: TreeKey
pmTreeKey = TreeKey
mtree
}
PLIArchive Archive
_ PackageMetadata
pm' -> PackageMetadata
pm'
PLIRepo Repo
_ PackageMetadata
pm' -> PackageMetadata
pm'
let exc :: PantryException
exc = RawPackageLocationImmutable
-> RawPackageMetadata
-> Maybe TreeKey
-> PackageIdentifier
-> PantryException
MismatchedPackageMetadata (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
loc) (PackageMetadata -> RawPackageMetadata
toRawPM PackageMetadata
pm) Maybe TreeKey
forall a. Maybe a
Nothing
(GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier GenericPackageDescription
gpd)
PackageIdentifier PackageName
name Version
ver = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm
RIO env GenericPackageDescription
-> (GenericPackageDescription -> RIO env GenericPackageDescription)
-> Maybe GenericPackageDescription
-> RIO env GenericPackageDescription
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PantryException -> RIO env GenericPackageDescription
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc) GenericPackageDescription -> RIO env GenericPackageDescription
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GenericPackageDescription
-> RIO env GenericPackageDescription)
-> Maybe GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ PackageName
name PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> Version
gpdVersion GenericPackageDescription
gpd
GenericPackageDescription -> Maybe GenericPackageDescription
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
gpd
where
withCache :: m GenericPackageDescription -> m GenericPackageDescription
withCache m GenericPackageDescription
inner = do
let rawLoc :: RawPackageLocationImmutable
rawLoc = PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
loc
IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref <- Getting
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
(Map RawPackageLocationImmutable GenericPackageDescription))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
(Map RawPackageLocationImmutable GenericPackageDescription)))
-> Getting
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
(Map RawPackageLocationImmutable GenericPackageDescription))
forall a b. (a -> b) -> a -> b
$ (PantryConfig
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
PantryConfig)
-> s
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' s PantryConfig
pantryConfigL((PantryConfig
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
PantryConfig)
-> s
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s)
-> ((IORef
(Map RawPackageLocationImmutable GenericPackageDescription)
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
(IORef
(Map RawPackageLocationImmutable GenericPackageDescription)))
-> PantryConfig
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
PantryConfig)
-> Getting
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig
-> IORef
(Map RawPackageLocationImmutable GenericPackageDescription))
-> SimpleGetter
PantryConfig
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig
-> IORef
(Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable
Map RawPackageLocationImmutable GenericPackageDescription
m0 <- IORef (Map RawPackageLocationImmutable GenericPackageDescription)
-> m (Map RawPackageLocationImmutable GenericPackageDescription)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref
case RawPackageLocationImmutable
-> Map RawPackageLocationImmutable GenericPackageDescription
-> Maybe GenericPackageDescription
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
rawLoc Map RawPackageLocationImmutable GenericPackageDescription
m0 of
Just GenericPackageDescription
x -> GenericPackageDescription -> m GenericPackageDescription
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
x
Maybe GenericPackageDescription
Nothing -> do
GenericPackageDescription
x <- m GenericPackageDescription
inner
IORef (Map RawPackageLocationImmutable GenericPackageDescription)
-> (Map RawPackageLocationImmutable GenericPackageDescription
-> (Map RawPackageLocationImmutable GenericPackageDescription,
GenericPackageDescription))
-> m GenericPackageDescription
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref ((Map RawPackageLocationImmutable GenericPackageDescription
-> (Map RawPackageLocationImmutable GenericPackageDescription,
GenericPackageDescription))
-> m GenericPackageDescription)
-> (Map RawPackageLocationImmutable GenericPackageDescription
-> (Map RawPackageLocationImmutable GenericPackageDescription,
GenericPackageDescription))
-> m GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ \Map RawPackageLocationImmutable GenericPackageDescription
m -> (RawPackageLocationImmutable
-> GenericPackageDescription
-> Map RawPackageLocationImmutable GenericPackageDescription
-> Map RawPackageLocationImmutable GenericPackageDescription
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RawPackageLocationImmutable
rawLoc GenericPackageDescription
x Map RawPackageLocationImmutable GenericPackageDescription
m, GenericPackageDescription
x)
loadCabalFileRawImmutable ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RIO env GenericPackageDescription
loadCabalFileRawImmutable :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileRawImmutable RawPackageLocationImmutable
loc = RIO env GenericPackageDescription
-> RIO env GenericPackageDescription
forall {m :: * -> *} {s}.
(MonadReader s m, HasPantryConfig s, MonadIO m) =>
m GenericPackageDescription -> m GenericPackageDescription
withCache (RIO env GenericPackageDescription
-> RIO env GenericPackageDescription)
-> RIO env GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Parsing cabal file for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
ByteString
bs <- RawPackageLocationImmutable -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env ByteString
loadRawCabalFileBytes RawPackageLocationImmutable
loc
([PWarning]
_warnings, GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> RIO env ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. a -> Either a b
Left RawPackageLocationImmutable
loc) ByteString
bs
let rpm :: RawPackageMetadata
rpm =
case RawPackageLocationImmutable
loc of
RPLIHackage (PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
_cfi) Maybe TreeKey
mtree -> RawPackageMetadata
{ rpmName :: Maybe PackageName
rpmName = PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just PackageName
name
, rpmVersion :: Maybe Version
rpmVersion = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
, rpmTreeKey :: Maybe TreeKey
rpmTreeKey = Maybe TreeKey
mtree
}
RPLIArchive RawArchive
_ RawPackageMetadata
rpm' -> RawPackageMetadata
rpm'
RPLIRepo Repo
_ RawPackageMetadata
rpm' -> RawPackageMetadata
rpm'
let exc :: PantryException
exc = RawPackageLocationImmutable
-> RawPackageMetadata
-> Maybe TreeKey
-> PackageIdentifier
-> PantryException
MismatchedPackageMetadata RawPackageLocationImmutable
loc RawPackageMetadata
rpm Maybe TreeKey
forall a. Maybe a
Nothing (GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier GenericPackageDescription
gpd)
RIO env GenericPackageDescription
-> (GenericPackageDescription -> RIO env GenericPackageDescription)
-> Maybe GenericPackageDescription
-> RIO env GenericPackageDescription
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PantryException -> RIO env GenericPackageDescription
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc) GenericPackageDescription -> RIO env GenericPackageDescription
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GenericPackageDescription
-> RIO env GenericPackageDescription)
-> Maybe GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> (PackageName -> Bool) -> Maybe PackageName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) (RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
rpm)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== GenericPackageDescription -> Version
gpdVersion GenericPackageDescription
gpd) (RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
rpm)
GenericPackageDescription -> Maybe GenericPackageDescription
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
gpd
where
withCache :: m GenericPackageDescription -> m GenericPackageDescription
withCache m GenericPackageDescription
inner = do
IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref <- Getting
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
(Map RawPackageLocationImmutable GenericPackageDescription))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
(Map RawPackageLocationImmutable GenericPackageDescription)))
-> Getting
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-> m (IORef
(Map RawPackageLocationImmutable GenericPackageDescription))
forall a b. (a -> b) -> a -> b
$ (PantryConfig
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
PantryConfig)
-> s
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' s PantryConfig
pantryConfigL((PantryConfig
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
PantryConfig)
-> s
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s)
-> ((IORef
(Map RawPackageLocationImmutable GenericPackageDescription)
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
(IORef
(Map RawPackageLocationImmutable GenericPackageDescription)))
-> PantryConfig
-> Const
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
PantryConfig)
-> Getting
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
s
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig
-> IORef
(Map RawPackageLocationImmutable GenericPackageDescription))
-> SimpleGetter
PantryConfig
(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig
-> IORef
(Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable
Map RawPackageLocationImmutable GenericPackageDescription
m0 <- IORef (Map RawPackageLocationImmutable GenericPackageDescription)
-> m (Map RawPackageLocationImmutable GenericPackageDescription)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref
case RawPackageLocationImmutable
-> Map RawPackageLocationImmutable GenericPackageDescription
-> Maybe GenericPackageDescription
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
loc Map RawPackageLocationImmutable GenericPackageDescription
m0 of
Just GenericPackageDescription
x -> GenericPackageDescription -> m GenericPackageDescription
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
x
Maybe GenericPackageDescription
Nothing -> do
GenericPackageDescription
x <- m GenericPackageDescription
inner
IORef (Map RawPackageLocationImmutable GenericPackageDescription)
-> (Map RawPackageLocationImmutable GenericPackageDescription
-> (Map RawPackageLocationImmutable GenericPackageDescription,
GenericPackageDescription))
-> m GenericPackageDescription
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Map RawPackageLocationImmutable GenericPackageDescription)
ref ((Map RawPackageLocationImmutable GenericPackageDescription
-> (Map RawPackageLocationImmutable GenericPackageDescription,
GenericPackageDescription))
-> m GenericPackageDescription)
-> (Map RawPackageLocationImmutable GenericPackageDescription
-> (Map RawPackageLocationImmutable GenericPackageDescription,
GenericPackageDescription))
-> m GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ \Map RawPackageLocationImmutable GenericPackageDescription
m -> (RawPackageLocationImmutable
-> GenericPackageDescription
-> Map RawPackageLocationImmutable GenericPackageDescription
-> Map RawPackageLocationImmutable GenericPackageDescription
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RawPackageLocationImmutable
loc GenericPackageDescription
x Map RawPackageLocationImmutable GenericPackageDescription
m, GenericPackageDescription
x)
loadCabalFileRaw ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Maybe Text
-> RawPackageLocation
-> RIO env GenericPackageDescription
loadCabalFileRaw :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> RawPackageLocation -> RIO env GenericPackageDescription
loadCabalFileRaw Maybe Text
_ (RPLImmutable RawPackageLocationImmutable
loc) = RawPackageLocationImmutable -> RIO env GenericPackageDescription
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileRawImmutable RawPackageLocationImmutable
loc
loadCabalFileRaw Maybe Text
progName (RPLMutable ResolvedPath Dir
rfp) = do
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
_) <- Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath Maybe Text
progName (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings
loadCabalFile ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Maybe Text
-> PackageLocation
-> RIO env GenericPackageDescription
loadCabalFile :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text -> PackageLocation -> RIO env GenericPackageDescription
loadCabalFile Maybe Text
_ (PLImmutable PackageLocationImmutable
loc) = PackageLocationImmutable -> RIO env GenericPackageDescription
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
loc
loadCabalFile Maybe Text
progName (PLMutable ResolvedPath Dir
rfp) = do
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
_) <- Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath Maybe Text
progName (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PrintWarnings -> IO GenericPackageDescription
gpdio PrintWarnings
NoPrintWarnings
loadCabalFilePath ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Maybe Text
-> Path Abs Dir
-> RIO env
( PrintWarnings -> IO GenericPackageDescription
, PackageName
, Path Abs File
)
loadCabalFilePath :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text
-> Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath Maybe Text
progName Path Abs Dir
dir = do
IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
ref <- Getting
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
env
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
-> RIO
env
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
env
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
-> RIO
env
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))))
-> Getting
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
env
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
-> RIO
env
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
forall a b. (a -> b) -> a -> b
$ (PantryConfig
-> Const
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
PantryConfig)
-> env
-> Const
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig
-> Const
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
PantryConfig)
-> env
-> Const
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
env)
-> ((IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
-> Const
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))))
-> PantryConfig
-> Const
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
PantryConfig)
-> Getting
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
env
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig
-> IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
-> SimpleGetter
PantryConfig
(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig
-> IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
pcParsedCabalFilesMutable
Maybe
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
mcached <- Path Abs Dir
-> Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
-> Maybe
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Path Abs Dir
dir (Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
-> Maybe
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
-> RIO
env
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
-> RIO
env
(Maybe
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
-> RIO
env
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
ref
case Maybe
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
mcached of
Just (PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
triple -> (PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
triple
Maybe
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
Nothing -> do
(PackageName
name, Path Abs File
cabalfp) <- Maybe Text -> Path Abs Dir -> RIO env (PackageName, Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text -> Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Maybe Text
progName Path Abs Dir
dir
IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef <- Maybe ([PWarning], GenericPackageDescription)
-> RIO env (IORef (Maybe ([PWarning], GenericPackageDescription)))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe ([PWarning], GenericPackageDescription)
forall a. Maybe a
Nothing
RIO env GenericPackageDescription -> IO GenericPackageDescription
run <- RIO
env
(RIO env GenericPackageDescription -> IO GenericPackageDescription)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
let gpdio :: PrintWarnings -> IO GenericPackageDescription
gpdio = RIO env GenericPackageDescription -> IO GenericPackageDescription
run (RIO env GenericPackageDescription -> IO GenericPackageDescription)
-> (PrintWarnings -> RIO env GenericPackageDescription)
-> PrintWarnings
-> IO GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File
-> IORef (Maybe ([PWarning], GenericPackageDescription))
-> PrintWarnings
-> RIO env GenericPackageDescription
forall {m :: * -> *} {env}.
(MonadIO m, MonadThrow m, MonadReader env m, HasLogFunc env) =>
Path Abs File
-> IORef (Maybe ([PWarning], GenericPackageDescription))
-> PrintWarnings
-> m GenericPackageDescription
getGPD Path Abs File
cabalfp IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef
triple :: (PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
triple = (PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
name, Path Abs File
cabalfp)
IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
-> (Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
-> (Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File),
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
ref ((Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
-> (Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File),
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
-> (Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
-> (Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File),
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)))
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall a b. (a -> b) -> a -> b
$ \Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
m -> (Path Abs Dir
-> (PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
-> Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
-> Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Path Abs Dir
dir (PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
triple Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
m, (PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
triple)
where
getGPD :: Path Abs File
-> IORef (Maybe ([PWarning], GenericPackageDescription))
-> PrintWarnings
-> m GenericPackageDescription
getGPD Path Abs File
cabalfp IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef PrintWarnings
printWarnings = do
Maybe ([PWarning], GenericPackageDescription)
mpair <- IORef (Maybe ([PWarning], GenericPackageDescription))
-> m (Maybe ([PWarning], GenericPackageDescription))
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef
([PWarning]
warnings0, GenericPackageDescription
gpd) <-
case Maybe ([PWarning], GenericPackageDescription)
mpair of
Just ([PWarning], GenericPackageDescription)
pair -> ([PWarning], GenericPackageDescription)
-> m ([PWarning], GenericPackageDescription)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PWarning], GenericPackageDescription)
pair
Maybe ([PWarning], GenericPackageDescription)
Nothing -> do
ByteString
bs <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
B.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
cabalfp
([PWarning]
warnings0, GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (Path Abs File -> Either RawPackageLocationImmutable (Path Abs File)
forall a b. b -> Either a b
Right Path Abs File
cabalfp) ByteString
bs
PackageName -> Path Abs File -> m ()
forall (m :: * -> *).
MonadThrow m =>
PackageName -> Path Abs File -> m ()
checkCabalFileName (GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) Path Abs File
cabalfp
([PWarning], GenericPackageDescription)
-> m ([PWarning], GenericPackageDescription)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PWarning]
warnings0, GenericPackageDescription
gpd)
[PWarning]
warnings <-
case PrintWarnings
printWarnings of
PrintWarnings
YesPrintWarnings -> (PWarning -> m ()) -> [PWarning] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ())
-> (PWarning -> Utf8Builder) -> PWarning -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> PWarning -> Utf8Builder
toPretty Path Abs File
cabalfp) [PWarning]
warnings0 m () -> [PWarning] -> m [PWarning]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []
PrintWarnings
NoPrintWarnings -> [PWarning] -> m [PWarning]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PWarning]
warnings0
IORef (Maybe ([PWarning], GenericPackageDescription))
-> Maybe ([PWarning], GenericPackageDescription) -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef (Maybe ([PWarning], GenericPackageDescription))
gpdRef (Maybe ([PWarning], GenericPackageDescription) -> m ())
-> Maybe ([PWarning], GenericPackageDescription) -> m ()
forall a b. (a -> b) -> a -> b
$ ([PWarning], GenericPackageDescription)
-> Maybe ([PWarning], GenericPackageDescription)
forall a. a -> Maybe a
Just ([PWarning]
warnings, GenericPackageDescription
gpd)
GenericPackageDescription -> m GenericPackageDescription
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericPackageDescription
gpd
toPretty :: Path Abs File -> PWarning -> Utf8Builder
toPretty :: Path Abs File -> PWarning -> Utf8Builder
toPretty Path Abs File
src (PWarning PWarnType
_type Position
pos String
msg) =
Utf8Builder
"Cabal file warning in " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
src) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"@" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Position -> String
showPos Position
pos) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
msg
checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m ()
checkCabalFileName :: forall (m :: * -> *).
MonadThrow m =>
PackageName -> Path Abs File -> m ()
checkCabalFileName PackageName
name Path Abs File
cabalfp = do
let expected :: String
expected = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ SafeFilePath -> Text
unSafeFilePath (SafeFilePath -> Text) -> SafeFilePath -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> SafeFilePath
cabalFileName PackageName
name
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
expected String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
cabalfp)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
PantryException -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (PantryException -> m ()) -> PantryException -> m ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> PackageName -> PantryException
MismatchedCabalName Path Abs File
cabalfp PackageName
name
findOrGenerateCabalFile ::
forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Maybe Text
-> Path Abs Dir
-> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text -> Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Maybe Text
progName Path Abs Dir
pkgDir = do
let hpackProgName :: Maybe ProgramName
hpackProgName = String -> ProgramName
forall a. IsString a => String -> a
fromString (String -> ProgramName) -> (Text -> String) -> Text -> ProgramName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> ProgramName) -> Maybe Text -> Maybe ProgramName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
progName
Maybe ProgramName -> Path Abs Dir -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe ProgramName -> Path Abs Dir -> RIO env ()
hpack Maybe ProgramName
hpackProgName Path Abs Dir
pkgDir
([Path Abs Dir]
_, [Path Abs File]
allFiles) <- Path Abs Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
pkgDir RIO env ([Path Abs Dir], [Path Abs File])
-> (IOException -> RIO env ([Path Abs Dir], [Path Abs File]))
-> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \IOException
e -> if IOException -> Bool
isDoesNotExistError IOException
e
then PantryException -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ([Path Abs Dir], [Path Abs File]))
-> PantryException -> RIO env ([Path Abs Dir], [Path Abs File])
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> PantryException
NoLocalPackageDirFound Path Abs Dir
pkgDir
else IOException -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOException
e
let files :: [Path Abs File]
files = (Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool) -> String -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> Bool
hasExtension String
"cabal" (String -> Bool)
-> (Path Abs File -> String) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath) [Path Abs File]
allFiles
let isHidden :: String -> Bool
isHidden (Char
'.':String
_) = Bool
True
isHidden String
_ = Bool
False
case (Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Path Abs File -> Bool) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isHidden (String -> Bool)
-> (Path Abs File -> String) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Rel File -> String)
-> (Path Abs File -> Path Rel File) -> Path Abs File -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename) [Path Abs File]
files of
[] -> PantryException -> RIO env (PackageName, Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (PackageName, Path Abs File))
-> PantryException -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> PantryException
NoCabalFileFound Path Abs Dir
pkgDir
[Path Abs File
x] -> RIO env (PackageName, Path Abs File)
-> (PackageName -> RIO env (PackageName, Path Abs File))
-> Maybe PackageName
-> RIO env (PackageName, Path Abs File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(PantryException -> RIO env (PackageName, Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (PackageName, Path Abs File))
-> PantryException -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs File -> PantryException
InvalidCabalFilePath Path Abs File
x)
(\PackageName
pn -> (PackageName, Path Abs File)
-> RIO env (PackageName, Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
pn, Path Abs File
x)) (Maybe PackageName -> RIO env (PackageName, Path Abs File))
-> Maybe PackageName -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$
String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripSuffix String
".cabal" (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
x)) Maybe String -> (String -> Maybe PackageName) -> Maybe PackageName
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
String -> Maybe PackageName
parsePackageName
Path Abs File
_:[Path Abs File]
_ -> PantryException -> RIO env (PackageName, Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env (PackageName, Path Abs File))
-> PantryException -> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Path Abs File] -> PantryException
MultipleCabalFilesFound Path Abs Dir
pkgDir [Path Abs File]
files
where
hasExtension :: String -> String -> Bool
hasExtension String
fp String
x = String -> String
FilePath.takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x
hpack ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Maybe Hpack.ProgramName
-> Path Abs Dir
-> RIO env ()
hpack :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe ProgramName -> Path Abs Dir -> RIO env ()
hpack Maybe ProgramName
progName Path Abs Dir
pkgDir = do
Path Rel File
packageConfigRelFile <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
Hpack.packageConfig
let hpackFile :: Path Abs File
hpackFile = Path Abs Dir
pkgDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
packageConfigRelFile
mHpackProgName :: Options -> Options
mHpackProgName = (Options -> Options)
-> (ProgramName -> Options -> Options)
-> Maybe ProgramName
-> Options
-> Options
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Options -> Options
forall a. a -> a
id ProgramName -> Options -> Options
Hpack.setProgramName Maybe ProgramName
progName
Bool
exists <- IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
hpackFile
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Running Hpack on " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
HpackExecutable
he <- Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable)
-> Getting HpackExecutable env HpackExecutable
-> RIO env HpackExecutable
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const HpackExecutable PantryConfig)
-> env -> Const HpackExecutable env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const HpackExecutable PantryConfig)
-> env -> Const HpackExecutable env)
-> ((HpackExecutable -> Const HpackExecutable HpackExecutable)
-> PantryConfig -> Const HpackExecutable PantryConfig)
-> Getting HpackExecutable env HpackExecutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> HpackExecutable)
-> SimpleGetter PantryConfig HpackExecutable
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> HpackExecutable
pcHpackExecutable
Force
hpackForce <- Getting Force env Force -> RIO env Force
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Force env Force -> RIO env Force)
-> Getting Force env Force -> RIO env Force
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const Force PantryConfig)
-> env -> Const Force env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const Force PantryConfig)
-> env -> Const Force env)
-> ((Force -> Const Force Force)
-> PantryConfig -> Const Force PantryConfig)
-> Getting Force env Force
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> Force) -> SimpleGetter PantryConfig Force
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Force
pcHpackForce
case HpackExecutable
he of
HpackExecutable
HpackBundled ->
IO (Either HpackError Result) -> RIO env (Either HpackError Result)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
( Options -> IO (Either HpackError Result)
Hpack.hpackResultWithError
(Options -> IO (Either HpackError Result))
-> Options -> IO (Either HpackError Result)
forall a b. (a -> b) -> a -> b
$ Options -> Options
mHpackProgName
(Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ (String -> IO (Either String ([String], Value)))
-> Options -> Options
Hpack.setDecode String -> IO (Either String ([String], Value))
decodeYaml
(Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ (String -> ParseException -> String) -> Options -> Options
Hpack.setFormatYamlParseError String -> ParseException -> String
formatYamlParseError
(Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ String -> Options -> Options
Hpack.setTarget
(Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
Options
Hpack.defaultOptions { Hpack.optionsForce = hpackForce }
)
RIO env (Either HpackError Result)
-> (Either HpackError Result -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
Left HpackError
err -> PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Path Abs File -> String -> PantryException
HpackLibraryException Path Abs File
hpackFile (String -> PantryException) -> String -> PantryException
forall a b. (a -> b) -> a -> b
$ ProgramName -> HpackError -> String
formatHpackError (ProgramName -> Maybe ProgramName -> ProgramName
forall a. a -> Maybe a -> a
fromMaybe ProgramName
"hpack" Maybe ProgramName
progName) HpackError
err)
Right Result
r -> do
[String] -> (String -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Result -> [String]
Hpack.resultWarnings Result
r) (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (String -> Utf8Builder) -> String -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Utf8Builder
forall a. IsString a => String -> a
fromString)
let cabalFile :: Utf8Builder
cabalFile = String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder)
-> (Result -> String) -> Result -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> String
Hpack.resultCabalFile (Result -> Utf8Builder) -> Result -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Result
r
case Result -> Status
Hpack.resultStatus Result
r of
Status
Hpack.Generated -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Hpack generated a modified version of "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
cabalFile
Status
Hpack.OutputUnchanged ->
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Hpack output unchanged in " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
cabalFile
Status
Hpack.AlreadyGeneratedByNewerHpack -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
cabalFile
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was generated with a newer version of Hpack. Ignoring "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in favor of the Cabal file.\n"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Either please upgrade and try again or, if you want to use the "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
hpackFile))
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" file instead of the Cabal file,\n"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"then please delete the Cabal file."
Status
Hpack.ExistingCabalFileWasModifiedManually -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
cabalFile
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was modified manually. Ignoring "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hpackFile)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" in favor of the Cabal file.\n"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"If you want to use the "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
hpackFile))
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" file instead of the Cabal file,\n"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"then please delete the Cabal file."
HpackCommand String
command -> do
let hpackArgs :: [String]
hpackArgs = case Force
hpackForce of
Force
Hpack.Force -> [String
"--force"]
Force
Hpack.NoForce -> []
RIO env () -> (SomeException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
( String -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
pkgDir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
String
-> [String] -> (ProcessConfig () () () -> RIO env ()) -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
command [String]
hpackArgs ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
)
( PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ())
-> (SomeException -> PantryException)
-> SomeException
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Path Abs Dir -> SomeException -> PantryException
HpackExeException String
command Path Abs Dir
pkgDir)
gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier = PackageDescription -> PackageIdentifier
D.package (PackageDescription -> PackageIdentifier)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
D.packageDescription
gpdPackageName :: GenericPackageDescription -> PackageName
gpdPackageName :: GenericPackageDescription -> PackageName
gpdPackageName = PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier
gpdVersion :: GenericPackageDescription -> Version
gpdVersion :: GenericPackageDescription -> Version
gpdVersion = PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version)
-> (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription
-> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageIdentifier
gpdPackageIdentifier
loadCabalFileBytes ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> PackageLocationImmutable
-> RIO env ByteString
loadCabalFileBytes :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env ByteString
loadCabalFileBytes (PLIHackage PackageIdentifier
pident BlobKey
cfHash TreeKey
_mtree) =
PackageIdentifierRevision -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile (PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash PackageIdentifier
pident BlobKey
cfHash)
loadCabalFileBytes PackageLocationImmutable
pl = do
Package
package <- PackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env Package
loadPackage PackageLocationImmutable
pl
let sfp :: SafeFilePath
sfp = PackageName -> SafeFilePath
cabalFileName (PackageName -> SafeFilePath) -> PackageName -> SafeFilePath
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdent Package
package
BlobKey
cabalBlobKey <- case Package -> PackageCabal
packageCabalEntry Package
package of
PCHpack PHpack
pcHpack -> BlobKey -> RIO env BlobKey
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlobKey -> RIO env BlobKey) -> BlobKey -> RIO env BlobKey
forall a b. (a -> b) -> a -> b
$ TreeEntry -> BlobKey
teBlob (TreeEntry -> BlobKey)
-> (PHpack -> TreeEntry) -> PHpack -> BlobKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PHpack -> TreeEntry
phGenerated (PHpack -> BlobKey) -> PHpack -> BlobKey
forall a b. (a -> b) -> a -> b
$ PHpack
pcHpack
PCCabalFile (TreeEntry BlobKey
blobKey FileType
_) -> BlobKey -> RIO env BlobKey
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobKey
blobKey
Maybe ByteString
mbs <- ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString))
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
cabalBlobKey
case Maybe ByteString
mbs of
Maybe ByteString
Nothing -> do
PantryException -> RIO env ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ByteString)
-> PantryException -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
TreeReferencesMissingBlob (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
pl) SafeFilePath
sfp BlobKey
cabalBlobKey
Just ByteString
bs -> ByteString -> RIO env ByteString
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
loadRawCabalFileBytes ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RIO env ByteString
loadRawCabalFileBytes :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env ByteString
loadRawCabalFileBytes (RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_mtree) = PackageIdentifierRevision -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile PackageIdentifierRevision
pir
loadRawCabalFileBytes RawPackageLocationImmutable
pl = do
Package
package <- RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
pl
let sfp :: SafeFilePath
sfp = PackageName -> SafeFilePath
cabalFileName (PackageName -> SafeFilePath) -> PackageName -> SafeFilePath
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdent Package
package
TreeEntry BlobKey
cabalBlobKey FileType
_ft = case Package -> PackageCabal
packageCabalEntry Package
package of
PCCabalFile TreeEntry
cabalTE -> TreeEntry
cabalTE
PCHpack PHpack
hpackCE -> PHpack -> TreeEntry
phGenerated PHpack
hpackCE
Maybe ByteString
mbs <- ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString))
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
cabalBlobKey
case Maybe ByteString
mbs of
Maybe ByteString
Nothing -> do
PantryException -> RIO env ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ByteString)
-> PantryException -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> SafeFilePath -> BlobKey -> PantryException
TreeReferencesMissingBlob RawPackageLocationImmutable
pl SafeFilePath
sfp BlobKey
cabalBlobKey
Just ByteString
bs -> ByteString -> RIO env ByteString
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
loadPackage ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> PackageLocationImmutable
-> RIO env Package
loadPackage :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env Package
loadPackage = RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw (RawPackageLocationImmutable -> RIO env Package)
-> (PackageLocationImmutable -> RawPackageLocationImmutable)
-> PackageLocationImmutable
-> RIO env Package
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI
loadPackageRaw ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RIO env Package
loadPackageRaw :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
rpli = do
case RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey RawPackageLocationImmutable
rpli of
Just TreeKey
treeKey' -> do
Maybe Package
mpackage <- RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
rpli TreeKey
treeKey'
RIO env Package
-> (Package -> RIO env Package) -> Maybe Package -> RIO env Package
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RIO env Package
loadPackageRawViaThirdParty Package -> RIO env Package
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
mpackage
Maybe TreeKey
Nothing -> RIO env Package
loadPackageRawViaThirdParty
where
loadPackageRawViaThirdParty :: RIO env Package
loadPackageRawViaThirdParty = do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loading package from third-party: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
case RawPackageLocationImmutable
rpli of
RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
mtree -> HackageTarballResult -> Package
htrPackage (HackageTarballResult -> Package)
-> RIO env HackageTarballResult -> RIO env Package
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
mtree
RPLIArchive RawArchive
archive RawPackageMetadata
pm -> RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env Package
getArchivePackage RawPackageLocationImmutable
rpli RawArchive
archive RawPackageMetadata
pm
RPLIRepo Repo
repo RawPackageMetadata
rpm -> Repo -> RawPackageMetadata -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env Package
getRepo Repo
repo RawPackageMetadata
rpm
tryLoadPackageRawViaDbOrCasa ::
(HasLogFunc env, HasPantryConfig env, HasProcessContext env)
=> RawPackageLocationImmutable
-> TreeKey
-> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
rpli TreeKey
treeKey' = MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (RIO env) Package -> RIO env (Maybe Package))
-> MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall a b. (a -> b) -> a -> b
$
MaybeT (RIO env) Package
tryViaLocalDb MaybeT (RIO env) Package
-> MaybeT (RIO env) Package -> MaybeT (RIO env) Package
forall a.
MaybeT (RIO env) a -> MaybeT (RIO env) a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT (RIO env) Package
tryCasa
where
tryViaLocalDb :: MaybeT (RIO env) Package
tryViaLocalDb = do
Package
package <- RIO env (Maybe Package) -> MaybeT (RIO env) Package
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe Package) -> MaybeT (RIO env) Package)
-> RIO env (Maybe Package) -> MaybeT (RIO env) Package
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rpli TreeKey
treeKey'
RIO env () -> MaybeT (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> MaybeT (RIO env) ())
-> RIO env () -> MaybeT (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded package from Pantry: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
Package -> MaybeT (RIO env) Package
forall a. a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Package
package
tryCasa :: MaybeT (RIO env) Package
tryCasa = do
MaybeT (RIO env) (CasaRepoPrefix, Int) -> MaybeT (RIO env) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MaybeT (RIO env) (CasaRepoPrefix, Int) -> MaybeT (RIO env) ())
-> MaybeT (RIO env) (CasaRepoPrefix, Int) -> MaybeT (RIO env) ()
forall a b. (a -> b) -> a -> b
$ RIO env (Maybe (CasaRepoPrefix, Int))
-> MaybeT (RIO env) (CasaRepoPrefix, Int)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe (CasaRepoPrefix, Int))
-> MaybeT (RIO env) (CasaRepoPrefix, Int))
-> RIO env (Maybe (CasaRepoPrefix, Int))
-> MaybeT (RIO env) (CasaRepoPrefix, Int)
forall a b. (a -> b) -> a -> b
$ Getting
(Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
-> RIO env (Maybe (CasaRepoPrefix, Int))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
(Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
-> RIO env (Maybe (CasaRepoPrefix, Int)))
-> Getting
(Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
-> RIO env (Maybe (CasaRepoPrefix, Int))
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const (Maybe (CasaRepoPrefix, Int)) PantryConfig)
-> env -> Const (Maybe (CasaRepoPrefix, Int)) env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL ((PantryConfig -> Const (Maybe (CasaRepoPrefix, Int)) PantryConfig)
-> env -> Const (Maybe (CasaRepoPrefix, Int)) env)
-> ((Maybe (CasaRepoPrefix, Int)
-> Const
(Maybe (CasaRepoPrefix, Int)) (Maybe (CasaRepoPrefix, Int)))
-> PantryConfig
-> Const (Maybe (CasaRepoPrefix, Int)) PantryConfig)
-> Getting
(Maybe (CasaRepoPrefix, Int)) env (Maybe (CasaRepoPrefix, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PantryConfig -> Maybe (CasaRepoPrefix, Int))
-> SimpleGetter PantryConfig (Maybe (CasaRepoPrefix, Int))
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Maybe (CasaRepoPrefix, Int)
pcCasaConfig
Package
package <- RIO env (Maybe Package) -> MaybeT (RIO env) Package
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe Package) -> MaybeT (RIO env) Package)
-> RIO env (Maybe Package) -> MaybeT (RIO env) Package
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaCasa RawPackageLocationImmutable
rpli TreeKey
treeKey'
RIO env () -> MaybeT (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> MaybeT (RIO env) ())
-> RIO env () -> MaybeT (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded package from Casa: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rpli)
Package -> MaybeT (RIO env) Package
forall a. a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Package
package
tryLoadPackageRawViaCasa ::
(HasLogFunc env, HasPantryConfig env, HasProcessContext env)
=> RawPackageLocationImmutable
-> TreeKey
-> RIO env (Maybe Package)
tryLoadPackageRawViaCasa :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaCasa RawPackageLocationImmutable
rlpi TreeKey
treeKey' = MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (RIO env) Package -> RIO env (Maybe Package))
-> MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall a b. (a -> b) -> a -> b
$ do
(TreeKey
treeKey'', Tree
_) <- RIO env (Maybe (TreeKey, Tree)) -> MaybeT (RIO env) (TreeKey, Tree)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe (TreeKey, Tree))
-> MaybeT (RIO env) (TreeKey, Tree))
-> RIO env (Maybe (TreeKey, Tree))
-> MaybeT (RIO env) (TreeKey, Tree)
forall a b. (a -> b) -> a -> b
$ TreeKey -> RIO env (Maybe (TreeKey, Tree))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
TreeKey -> RIO env (Maybe (TreeKey, Tree))
casaLookupTree TreeKey
treeKey'
RIO env () -> MaybeT (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> MaybeT (RIO env) ())
-> RIO env () -> MaybeT (RIO env) ()
forall a b. (a -> b) -> a -> b
$ [RawPackageLocationImmutable] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys [RawPackageLocationImmutable
rlpi]
TreeKey -> MaybeT (RIO env) Package
tryViaLocalDb TreeKey
treeKey'' MaybeT (RIO env) Package
-> MaybeT (RIO env) Package -> MaybeT (RIO env) Package
forall a.
MaybeT (RIO env) a -> MaybeT (RIO env) a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TreeKey -> MaybeT (RIO env) Package
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {env} {a} {b}.
(MonadTrans t, Monad (t m), MonadIO m, MonadReader env m,
HasLogFunc env, Display a, Alternative (t m)) =>
a -> t m b
warn TreeKey
treeKey''
where
tryViaLocalDb :: TreeKey -> MaybeT (RIO env) Package
tryViaLocalDb = RIO env (Maybe Package) -> MaybeT (RIO env) Package
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe Package) -> MaybeT (RIO env) Package)
-> (TreeKey -> RIO env (Maybe Package))
-> TreeKey
-> MaybeT (RIO env) Package
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rlpi
warn :: a -> t m b
warn a
treeKey'' = do
m () -> t m ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> m () -> t m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Did not find tree key in DB after pulling it from Casa: "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
treeKey''
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (for "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
rlpi
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
t m b
forall a. t m a
forall (f :: * -> *) a. Alternative f => f a
empty
tryLoadPackageRawViaLocalDb ::
(HasLogFunc env, HasPantryConfig env, HasProcessContext env)
=> RawPackageLocationImmutable
-> TreeKey
-> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rlpi TreeKey
treeKey' = MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (RIO env) Package -> RIO env (Maybe Package))
-> MaybeT (RIO env) Package -> RIO env (Maybe Package)
forall a b. (a -> b) -> a -> b
$ do
Entity Tree
treeId <- RIO env (Maybe (Entity Tree)) -> MaybeT (RIO env) (Entity Tree)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (RIO env (Maybe (Entity Tree)) -> MaybeT (RIO env) (Entity Tree))
-> RIO env (Maybe (Entity Tree)) -> MaybeT (RIO env) (Entity Tree)
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
-> RIO env (Maybe (Entity Tree))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
forall env.
TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree))
getTreeForKey TreeKey
treeKey')
RIO env Package -> MaybeT (RIO env) Package
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env Package -> MaybeT (RIO env) Package)
-> RIO env Package -> MaybeT (RIO env) Package
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) Package -> RIO env Package
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> TreeId -> ReaderT SqlBackend (RIO env) Package
loadPackageById RawPackageLocationImmutable
rlpi (Entity Tree -> TreeId
forall record. Entity record -> Key record
entityKey Entity Tree
treeId))
data CompletePackageLocation = CompletePackageLocation
{ CompletePackageLocation -> PackageLocationImmutable
cplComplete :: !PackageLocationImmutable
, CompletePackageLocation -> Bool
cplHasCabalFile :: !Bool
}
completePackageLocation ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RIO env CompletePackageLocation
completePackageLocation :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation (RPLIHackage (PackageIdentifierRevision PackageName
n Version
v (CFIHash SHA256
sha (Just FileSize
size))) (Just TreeKey
tk)) =
CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation
{ cplComplete :: PackageLocationImmutable
cplComplete = PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
n Version
v) (SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size) TreeKey
tk
, cplHasCabalFile :: Bool
cplHasCabalFile = Bool
True
}
completePackageLocation (RPLIHackage pir0 :: PackageIdentifierRevision
pir0@(PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi0) Maybe TreeKey
_) = do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Completing package location information from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir0
(PackageIdentifierRevision
pir, BlobKey
cfKey) <-
case CabalFileInfo
cfi0 of
CFIHash SHA256
sha (Just FileSize
size) -> (PackageIdentifierRevision, BlobKey)
-> RIO env (PackageIdentifierRevision, BlobKey)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifierRevision
pir0, SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size)
CabalFileInfo
_ -> do
ByteString
bs <- PackageIdentifierRevision -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile PackageIdentifierRevision
pir0
let size :: FileSize
size = Word -> FileSize
FileSize (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs))
sha :: SHA256
sha = ByteString -> SHA256
SHA256.hashBytes ByteString
bs
cfi :: CabalFileInfo
cfi = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)
pir :: PackageIdentifierRevision
pir = PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Added in cabal file hash: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir
(PackageIdentifierRevision, BlobKey)
-> RIO env (PackageIdentifierRevision, BlobKey)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifierRevision
pir, SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size)
TreeKey
treeKey' <- PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation
{ cplComplete :: PackageLocationImmutable
cplComplete = PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey'
, cplHasCabalFile :: Bool
cplHasCabalFile = Bool
True
}
completePackageLocation pl :: RawPackageLocationImmutable
pl@(RPLIArchive RawArchive
archive RawPackageMetadata
rpm) = do
Maybe Package
mpackage <-
case RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm of
Just TreeKey
treeKey' -> RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
pl TreeKey
treeKey'
Maybe TreeKey
Nothing -> Maybe Package -> RIO env (Maybe Package)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
case (,,) (SHA256 -> FileSize -> Package -> (SHA256, FileSize, Package))
-> Maybe SHA256
-> Maybe (FileSize -> Package -> (SHA256, FileSize, Package))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawArchive -> Maybe SHA256
raHash RawArchive
archive Maybe (FileSize -> Package -> (SHA256, FileSize, Package))
-> Maybe FileSize -> Maybe (Package -> (SHA256, FileSize, Package))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RawArchive -> Maybe FileSize
raSize RawArchive
archive Maybe (Package -> (SHA256, FileSize, Package))
-> Maybe Package -> Maybe (SHA256, FileSize, Package)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Package
mpackage of
Just (SHA256
sha256, FileSize
fileSize, Package
package) -> do
let RawArchive ArchiveLocation
loc Maybe SHA256
_ Maybe FileSize
_ Text
subdir = RawArchive
archive
CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation
{ cplComplete :: PackageLocationImmutable
cplComplete = Archive -> PackageMetadata -> PackageLocationImmutable
PLIArchive (ArchiveLocation -> SHA256 -> FileSize -> Text -> Archive
Archive ArchiveLocation
loc SHA256
sha256 FileSize
fileSize Text
subdir) (Package -> PackageMetadata
packagePM Package
package)
, cplHasCabalFile :: Bool
cplHasCabalFile =
case Package -> PackageCabal
packageCabalEntry Package
package of
PCCabalFile{} -> Bool
True
PCHpack{} -> Bool
False
}
Maybe (SHA256, FileSize, Package)
Nothing -> Bool -> RIO env CompletePackageLocation
forall {env}.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> RIO env CompletePackageLocation
byThirdParty (Maybe Package -> Bool
forall a. Maybe a -> Bool
isJust Maybe Package
mpackage)
where
byThirdParty :: Bool -> RIO env CompletePackageLocation
byThirdParty Bool
warnAboutMissingSizeSha = do
(SHA256
sha, FileSize
size, Package
package, CachedTree
_cachedTree) <- RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive RawPackageLocationImmutable
pl RawArchive
archive RawPackageMetadata
rpm
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warnAboutMissingSizeSha (SHA256 -> FileSize -> RIO env ()
forall {m :: * -> *} {env} {a} {a}.
(MonadIO m, MonadReader env m, HasLogFunc env, Display a,
Display a) =>
a -> a -> m ()
warnWith SHA256
sha FileSize
size)
let RawArchive ArchiveLocation
loc Maybe SHA256
_ Maybe FileSize
_ Text
subdir = RawArchive
archive
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> String -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ (RawPackageLocationImmutable, SHA256, FileSize, Package) -> String
forall a. Show a => a -> String
show (RawPackageLocationImmutable
pl, SHA256
sha, FileSize
size, Package
package)
CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation
{ cplComplete :: PackageLocationImmutable
cplComplete = Archive -> PackageMetadata -> PackageLocationImmutable
PLIArchive (ArchiveLocation -> SHA256 -> FileSize -> Text -> Archive
Archive ArchiveLocation
loc SHA256
sha FileSize
size Text
subdir) (Package -> PackageMetadata
packagePM Package
package)
, cplHasCabalFile :: Bool
cplHasCabalFile =
case Package -> PackageCabal
packageCabalEntry Package
package of
PCCabalFile{} -> Bool
True
PCHpack{} -> Bool
False
}
warnWith :: a -> a -> m ()
warnWith a
sha a
size =
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
([Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
[ Utf8Builder
"The package "
, RawPackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
pl
, Utf8Builder
" is available from the local content-addressable storage database, \n"
, Utf8Builder
"but we can't use it unless you specify the size and hash for this package.\n"
, Utf8Builder
"Add the following to your package description:\n"
, Utf8Builder
"\nsize: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
size
, Utf8Builder
"\nsha256: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
sha
])
completePackageLocation pl :: RawPackageLocationImmutable
pl@(RPLIRepo Repo
repo RawPackageMetadata
rpm) = do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
isSHA1 (Repo -> Text
repoCommit Repo
repo)) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Repo -> PantryException
CannotCompleteRepoNonSHA1 Repo
repo
Repo
-> RawPackageLocationImmutable
-> RawPackageMetadata
-> RIO env CompletePackageLocation
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo
-> RawPackageLocationImmutable
-> RawPackageMetadata
-> RIO env CompletePackageLocation
completePM Repo
repo RawPackageLocationImmutable
pl RawPackageMetadata
rpm
where
isSHA1 :: Text -> Bool
isSHA1 Text
t = Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
40 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isHexDigit Text
t
completePM ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Repo
-> RawPackageLocationImmutable
-> RawPackageMetadata
-> RIO env CompletePackageLocation
completePM :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo
-> RawPackageLocationImmutable
-> RawPackageMetadata
-> RIO env CompletePackageLocation
completePM Repo
repo RawPackageLocationImmutable
plOrig rpm :: RawPackageMetadata
rpm@(RawPackageMetadata Maybe PackageName
mn Maybe Version
mv Maybe TreeKey
mtk)
| Just PackageName
n <- Maybe PackageName
mn, Just Version
v <- Maybe Version
mv, Just TreeKey
tk <- Maybe TreeKey
mtk = do
let pm :: PackageMetadata
pm = PackageIdentifier -> TreeKey -> PackageMetadata
PackageMetadata (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
n Version
v) TreeKey
tk
CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation
{ cplComplete :: PackageLocationImmutable
cplComplete = Repo -> PackageMetadata -> PackageLocationImmutable
PLIRepo Repo
repo PackageMetadata
pm
, cplHasCabalFile :: Bool
cplHasCabalFile = Bool
True
}
| Bool
otherwise = do
Package
package <- RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
plOrig
let pm :: PackageMetadata
pm = Package -> PackageMetadata
packagePM Package
package
let isSame :: a -> Maybe a -> Bool
isSame a
x (Just a
y) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
isSame a
_ Maybe a
_ = Bool
True
allSame :: Bool
allSame =
PackageName -> Maybe PackageName -> Bool
forall {a}. Eq a => a -> Maybe a -> Bool
isSame (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm) (RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
rpm) Bool -> Bool -> Bool
&&
Version -> Maybe Version -> Bool
forall {a}. Eq a => a -> Maybe a -> Bool
isSame (PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Version) -> PackageIdentifier -> Version
forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm) (RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
rpm) Bool -> Bool -> Bool
&&
TreeKey -> Maybe TreeKey -> Bool
forall {a}. Eq a => a -> Maybe a -> Bool
isSame (PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm) (RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm)
if Bool
allSame
then CompletePackageLocation -> RIO env CompletePackageLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation
{ cplComplete :: PackageLocationImmutable
cplComplete = Repo -> PackageMetadata -> PackageLocationImmutable
PLIRepo Repo
repo PackageMetadata
pm
, cplHasCabalFile :: Bool
cplHasCabalFile =
case Package -> PackageCabal
packageCabalEntry Package
package of
PCCabalFile{} -> Bool
True
PCHpack{} -> Bool
False
}
else PantryException -> RIO env CompletePackageLocation
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env CompletePackageLocation)
-> PantryException -> RIO env CompletePackageLocation
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> PackageMetadata -> PantryException
CompletePackageMetadataMismatch RawPackageLocationImmutable
plOrig PackageMetadata
pm
packagePM :: Package -> PackageMetadata
packagePM :: Package -> PackageMetadata
packagePM Package
package = PackageMetadata
{ pmIdent :: PackageIdentifier
pmIdent = Package -> PackageIdentifier
packageIdent Package
package
, pmTreeKey :: TreeKey
pmTreeKey = Package -> TreeKey
packageTreeKey Package
package
}
completeSnapshotLocation ::
(HasPantryConfig env, HasLogFunc env)
=> RawSnapshotLocation
-> RIO env SnapshotLocation
completeSnapshotLocation :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation (RSLCompiler WantedCompiler
c) = SnapshotLocation -> RIO env SnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> SnapshotLocation
SLCompiler WantedCompiler
c
completeSnapshotLocation (RSLFilePath ResolvedPath File
f) = SnapshotLocation -> RIO env SnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> SnapshotLocation
SLFilePath ResolvedPath File
f
completeSnapshotLocation (RSLUrl Text
url (Just BlobKey
blobKey)) = SnapshotLocation -> RIO env SnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ Text -> BlobKey -> SnapshotLocation
SLUrl Text
url BlobKey
blobKey
completeSnapshotLocation (RSLUrl Text
url Maybe BlobKey
Nothing) = do
ByteString
bs <- Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url Maybe BlobKey
forall a. Maybe a
Nothing
SnapshotLocation -> RIO env SnapshotLocation
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotLocation -> RIO env SnapshotLocation)
-> SnapshotLocation -> RIO env SnapshotLocation
forall a b. (a -> b) -> a -> b
$ Text -> BlobKey -> SnapshotLocation
SLUrl Text
url (ByteString -> BlobKey
bsToBlobKey ByteString
bs)
completeSnapshotLocation (RSLSynonym SnapName
syn) =
RawSnapshotLocation -> RIO env SnapshotLocation
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation (RawSnapshotLocation -> RIO env SnapshotLocation)
-> RIO env RawSnapshotLocation -> RIO env SnapshotLocation
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SnapName -> RIO env RawSnapshotLocation
forall env.
HasPantryConfig env =>
SnapName -> RIO env RawSnapshotLocation
snapshotLocation SnapName
syn
traverseConcurrently_ ::
(Foldable f, HasPantryConfig env)
=> (a -> RIO env ())
-> f a
-> RIO env ()
traverseConcurrently_ :: forall (f :: * -> *) env a.
(Foldable f, HasPantryConfig env) =>
(a -> RIO env ()) -> f a -> RIO env ()
traverseConcurrently_ a -> RIO env ()
f f a
t0 = do
Int
cnt <- Getting Int env Int -> RIO env Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Int env Int -> RIO env Int)
-> Getting Int env Int -> RIO env Int
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const Int PantryConfig) -> env -> Const Int env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const Int PantryConfig) -> env -> Const Int env)
-> ((Int -> Const Int Int)
-> PantryConfig -> Const Int PantryConfig)
-> Getting Int env Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> Int) -> SimpleGetter PantryConfig Int
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Int
pcConnectionCount
Int -> (a -> RIO env ()) -> f a -> RIO env ()
forall (m :: * -> *) (f :: * -> *) a.
(MonadUnliftIO m, Foldable f) =>
Int -> (a -> m ()) -> f a -> m ()
traverseConcurrentlyWith_ Int
cnt a -> RIO env ()
f f a
t0
traverseConcurrentlyWith_ ::
(MonadUnliftIO m, Foldable f)
=> Int
-> (a -> m ())
-> f a
-> m ()
traverseConcurrentlyWith_ :: forall (m :: * -> *) (f :: * -> *) a.
(MonadUnliftIO m, Foldable f) =>
Int -> (a -> m ()) -> f a -> m ()
traverseConcurrentlyWith_ Int
count a -> m ()
f f a
t0 = do
TVar [a]
queue <- [a] -> m (TVar [a])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ([a] -> m (TVar [a])) -> [a] -> m (TVar [a])
forall a b. (a -> b) -> a -> b
$ f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
t0
Int -> m () -> m ()
forall (m :: * -> *) a.
(Applicative m, MonadUnliftIO m) =>
Int -> m a -> m ()
replicateConcurrently_ Int
count (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
(m () -> m ()) -> m ()
forall a. (a -> a) -> a
fix ((m () -> m ()) -> m ()) -> (m () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \m ()
loop -> m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ STM (m ()) -> m (m ())
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (m ()) -> m (m ())) -> STM (m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ do
[a]
toProcess <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
queue
case [a]
toProcess of
[] -> m () -> STM (m ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
(a
x:[a]
rest) -> do
TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
queue [a]
rest
m () -> STM (m ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> STM (m ())) -> m () -> STM (m ())
forall a b. (a -> b) -> a -> b
$ do
a -> m ()
f a
x
m ()
loop
loadSnapshotRaw ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawSnapshotLocation
-> RIO env RawSnapshot
loadSnapshotRaw :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation -> RIO env RawSnapshot
loadSnapshotRaw RawSnapshotLocation
loc = do
Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres <- RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer RawSnapshotLocation
loc
case Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres of
Left WantedCompiler
wc ->
RawSnapshot -> RIO env RawSnapshot
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot
{ rsCompiler :: WantedCompiler
rsCompiler = WantedCompiler
wc
, rsPackages :: Map PackageName RawSnapshotPackage
rsPackages = Map PackageName RawSnapshotPackage
forall a. Monoid a => a
mempty
, rsDrop :: Set PackageName
rsDrop = Set PackageName
forall a. Monoid a => a
mempty
}
Right (RawSnapshotLayer
rsl, CompletedSL
_) -> do
RawSnapshot
snap0 <- RawSnapshotLocation -> RIO env RawSnapshot
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation -> RIO env RawSnapshot
loadSnapshotRaw (RawSnapshotLocation -> RIO env RawSnapshot)
-> RawSnapshotLocation -> RIO env RawSnapshot
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsl
(Map PackageName RawSnapshotPackage
packages, AddPackagesConfig
unused) <-
Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
addPackagesToSnapshot
(RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
loc)
(RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsl)
AddPackagesConfig
{ apcDrop :: Set PackageName
apcDrop = RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsl
, apcFlags :: Map PackageName (Map FlagName Bool)
apcFlags = RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsl
, apcHiddens :: Map PackageName Bool
apcHiddens = RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsl
, apcGhcOptions :: Map PackageName [Text]
apcGhcOptions = RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsl
}
(RawSnapshot -> Map PackageName RawSnapshotPackage
rsPackages RawSnapshot
snap0)
Utf8Builder -> AddPackagesConfig -> RIO env ()
forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig (RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
loc) AddPackagesConfig
unused
RawSnapshot -> RIO env RawSnapshot
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot
{ rsCompiler :: WantedCompiler
rsCompiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
forall a. a -> Maybe a -> a
fromMaybe (RawSnapshot -> WantedCompiler
rsCompiler RawSnapshot
snap0) (RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler RawSnapshotLayer
rsl)
, rsPackages :: Map PackageName RawSnapshotPackage
rsPackages = Map PackageName RawSnapshotPackage
packages
, rsDrop :: Set PackageName
rsDrop = AddPackagesConfig -> Set PackageName
apcDrop AddPackagesConfig
unused
}
loadSnapshot ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> SnapshotLocation
-> RIO env RawSnapshot
loadSnapshot :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
SnapshotLocation -> RIO env RawSnapshot
loadSnapshot SnapshotLocation
loc = do
Either WantedCompiler RawSnapshotLayer
eres <- SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer SnapshotLocation
loc
case Either WantedCompiler RawSnapshotLayer
eres of
Left WantedCompiler
wc ->
RawSnapshot -> RIO env RawSnapshot
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot
{ rsCompiler :: WantedCompiler
rsCompiler = WantedCompiler
wc
, rsPackages :: Map PackageName RawSnapshotPackage
rsPackages = Map PackageName RawSnapshotPackage
forall a. Monoid a => a
mempty
, rsDrop :: Set PackageName
rsDrop = Set PackageName
forall a. Monoid a => a
mempty
}
Right RawSnapshotLayer
rsl -> do
RawSnapshot
snap0 <- RawSnapshotLocation -> RIO env RawSnapshot
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation -> RIO env RawSnapshot
loadSnapshotRaw (RawSnapshotLocation -> RIO env RawSnapshot)
-> RawSnapshotLocation -> RIO env RawSnapshot
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsl
(Map PackageName RawSnapshotPackage
packages, AddPackagesConfig
unused) <-
Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
addPackagesToSnapshot
(SnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SnapshotLocation
loc)
(RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsl)
AddPackagesConfig
{ apcDrop :: Set PackageName
apcDrop = RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsl
, apcFlags :: Map PackageName (Map FlagName Bool)
apcFlags = RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsl
, apcHiddens :: Map PackageName Bool
apcHiddens = RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsl
, apcGhcOptions :: Map PackageName [Text]
apcGhcOptions = RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsl
}
(RawSnapshot -> Map PackageName RawSnapshotPackage
rsPackages RawSnapshot
snap0)
Utf8Builder -> AddPackagesConfig -> RIO env ()
forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig (SnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SnapshotLocation
loc) AddPackagesConfig
unused
RawSnapshot -> RIO env RawSnapshot
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot
{ rsCompiler :: WantedCompiler
rsCompiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
forall a. a -> Maybe a -> a
fromMaybe (RawSnapshot -> WantedCompiler
rsCompiler RawSnapshot
snap0) (RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler RawSnapshotLayer
rsl)
, rsPackages :: Map PackageName RawSnapshotPackage
rsPackages = Map PackageName RawSnapshotPackage
packages
, rsDrop :: Set PackageName
rsDrop = AddPackagesConfig -> Set PackageName
apcDrop AddPackagesConfig
unused
}
data CompletedPLI
= CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable
data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation
loadAndCompleteSnapshot ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot = Bool
-> SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot' Bool
True
loadAndCompleteSnapshot' ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Bool
-> SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot' :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot' Bool
debugRSL SnapshotLocation
loc =
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
debugRSL (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
loc)
loadAndCompleteSnapshotRaw ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw = Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
True
loadAndCompleteSnapshotRaw' ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
debugRSL RawSnapshotLocation
rawLoc Map RawSnapshotLocation SnapshotLocation
cacheSL Map RawPackageLocationImmutable PackageLocationImmutable
cachePL = do
Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres <- case RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Maybe SnapshotLocation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawSnapshotLocation
rawLoc Map RawSnapshotLocation SnapshotLocation
cacheSL of
Just SnapshotLocation
loc -> (RawSnapshotLayer -> (RawSnapshotLayer, CompletedSL))
-> Either WantedCompiler RawSnapshotLayer
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall b c d. (b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right (, RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL RawSnapshotLocation
rawLoc SnapshotLocation
loc) (Either WantedCompiler RawSnapshotLayer
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer SnapshotLocation
loc
Maybe SnapshotLocation
Nothing -> RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer RawSnapshotLocation
rawLoc
case Either WantedCompiler (RawSnapshotLayer, CompletedSL)
eres of
Left WantedCompiler
wc ->
let snapshot :: Snapshot
snapshot = Snapshot
{ snapshotCompiler :: WantedCompiler
snapshotCompiler = WantedCompiler
wc
, snapshotPackages :: Map PackageName SnapshotPackage
snapshotPackages = Map PackageName SnapshotPackage
forall a. Monoid a => a
mempty
, snapshotDrop :: Set PackageName
snapshotDrop = Set PackageName
forall a. Monoid a => a
mempty
}
in (Snapshot, [CompletedSL], [CompletedPLI])
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Snapshot
snapshot, [RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL (WantedCompiler -> RawSnapshotLocation
RSLCompiler WantedCompiler
wc) (WantedCompiler -> SnapshotLocation
SLCompiler WantedCompiler
wc)], [])
Right (RawSnapshotLayer
rsl, CompletedSL
sloc) -> do
(Snapshot
snap0, [CompletedSL]
slocs, [CompletedPLI]
completed0) <- Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
debugRSL (RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsl) Map RawSnapshotLocation SnapshotLocation
cacheSL Map RawPackageLocationImmutable PackageLocationImmutable
cachePL
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugRSL (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> Utf8Builder
forall a. IsString a => String -> a
fromString (String -> Utf8Builder) -> String -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> String
forall a. Show a => a -> String
show RawSnapshotLayer
rsl
(Map PackageName SnapshotPackage
packages, [CompletedPLI]
completed, AddPackagesConfig
unused) <-
RawSnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName SnapshotPackage
-> RIO
env
(Map PackageName SnapshotPackage, [CompletedPLI],
AddPackagesConfig)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName SnapshotPackage
-> RIO
env
(Map PackageName SnapshotPackage, [CompletedPLI],
AddPackagesConfig)
addAndCompletePackagesToSnapshot
RawSnapshotLocation
rawLoc
Map RawPackageLocationImmutable PackageLocationImmutable
cachePL
(RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsl)
AddPackagesConfig
{ apcDrop :: Set PackageName
apcDrop = RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsl
, apcFlags :: Map PackageName (Map FlagName Bool)
apcFlags = RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsl
, apcHiddens :: Map PackageName Bool
apcHiddens = RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsl
, apcGhcOptions :: Map PackageName [Text]
apcGhcOptions = RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsl
}
(Snapshot -> Map PackageName SnapshotPackage
snapshotPackages Snapshot
snap0)
Utf8Builder -> AddPackagesConfig -> RIO env ()
forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig (RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
rawLoc) AddPackagesConfig
unused
let snapshot :: Snapshot
snapshot = Snapshot
{ snapshotCompiler :: WantedCompiler
snapshotCompiler = WantedCompiler -> Maybe WantedCompiler -> WantedCompiler
forall a. a -> Maybe a -> a
fromMaybe (Snapshot -> WantedCompiler
snapshotCompiler Snapshot
snap0) (RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler RawSnapshotLayer
rsl)
, snapshotPackages :: Map PackageName SnapshotPackage
snapshotPackages = Map PackageName SnapshotPackage
packages
, snapshotDrop :: Set PackageName
snapshotDrop = AddPackagesConfig -> Set PackageName
apcDrop AddPackagesConfig
unused
}
(Snapshot, [CompletedSL], [CompletedPLI])
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Snapshot
snapshot, CompletedSL
sloc CompletedSL -> [CompletedSL] -> [CompletedSL]
forall a. a -> [a] -> [a]
: [CompletedSL]
slocs,[CompletedPLI]
completed0 [CompletedPLI] -> [CompletedPLI] -> [CompletedPLI]
forall a. [a] -> [a] -> [a]
++ [CompletedPLI]
completed)
data SingleOrNot a
= Single !a
| Multiple !a !a !([a] -> [a])
instance Semigroup (SingleOrNot a) where
Single a
a <> :: SingleOrNot a -> SingleOrNot a -> SingleOrNot a
<> Single a
b = a -> a -> ([a] -> [a]) -> SingleOrNot a
forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b [a] -> [a]
forall a. a -> a
id
Single a
a <> Multiple a
b a
c [a] -> [a]
d = a -> a -> ([a] -> [a]) -> SingleOrNot a
forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b ((a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
d)
Multiple a
a a
b [a] -> [a]
c <> Single a
d = a -> a -> ([a] -> [a]) -> SingleOrNot a
forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b ([a] -> [a]
c ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
da -> [a] -> [a]
forall a. a -> [a] -> [a]
:))
Multiple a
a a
b [a] -> [a]
c <> Multiple a
d a
e [a] -> [a]
f =
a -> a -> ([a] -> [a]) -> SingleOrNot a
forall a. a -> a -> ([a] -> [a]) -> SingleOrNot a
Multiple a
a a
b ([a] -> [a]
c ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
da -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
ea -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
f)
sonToEither :: (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither :: forall k a. (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither (k
k, Single a
a) = (k, a) -> Either (k, a) (k, [a])
forall a b. a -> Either a b
Left (k
k, a
a)
sonToEither (k
k, Multiple a
a a
b [a] -> [a]
c) = (k, [a]) -> Either (k, a) (k, [a])
forall a b. b -> Either a b
Right (k
k, a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
c [])
data AddPackagesConfig = AddPackagesConfig
{ AddPackagesConfig -> Set PackageName
apcDrop :: !(Set PackageName)
, AddPackagesConfig -> Map PackageName (Map FlagName Bool)
apcFlags :: !(Map PackageName (Map FlagName Bool))
, AddPackagesConfig -> Map PackageName Bool
apcHiddens :: !(Map PackageName Bool)
, AddPackagesConfig -> Map PackageName [Text]
apcGhcOptions :: !(Map PackageName [Text])
}
warnUnusedAddPackagesConfig ::
HasLogFunc env
=> Utf8Builder
-> AddPackagesConfig
-> RIO env ()
warnUnusedAddPackagesConfig :: forall env.
HasLogFunc env =>
Utf8Builder -> AddPackagesConfig -> RIO env ()
warnUnusedAddPackagesConfig Utf8Builder
source (AddPackagesConfig Set PackageName
_drops Map PackageName (Map FlagName Bool)
flags Map PackageName Bool
hiddens Map PackageName [Text]
options) = do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Utf8Builder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Utf8Builder]
ls) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Some warnings discovered when adding packages to snapshot (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
source Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
(Utf8Builder -> RIO env ()) -> [Utf8Builder] -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn [Utf8Builder]
ls
where
ls :: [Utf8Builder]
ls = [[Utf8Builder]] -> [Utf8Builder]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Utf8Builder]
flags', [Utf8Builder]
hiddens', [Utf8Builder]
options']
flags' :: [Utf8Builder]
flags' =
(PackageName -> Utf8Builder) -> [PackageName] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map
(\PackageName
pn ->
Utf8Builder
"Setting flags for nonexistent package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
pn))
(Map PackageName (Map FlagName Bool) -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName (Map FlagName Bool)
flags)
hiddens' :: [Utf8Builder]
hiddens' =
(PackageName -> Utf8Builder) -> [PackageName] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map
(\PackageName
pn ->
Utf8Builder
"Hiding nonexistent package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
pn))
(Map PackageName Bool -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName Bool
hiddens)
options' :: [Utf8Builder]
options' =
(PackageName -> Utf8Builder) -> [PackageName] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map
(\PackageName
pn ->
Utf8Builder
"Setting options for nonexistent package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
pn))
(Map PackageName [Text] -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName [Text]
options)
addPackagesToSnapshot ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
addPackagesToSnapshot :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Utf8Builder
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName RawSnapshotPackage
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
addPackagesToSnapshot Utf8Builder
source [RawPackageLocationImmutable]
newPackages (AddPackagesConfig Set PackageName
drops Map PackageName (Map FlagName Bool)
flags Map PackageName Bool
hiddens Map PackageName [Text]
options) Map PackageName RawSnapshotPackage
old = do
[(PackageName, RawSnapshotPackage)]
new' <- [RawPackageLocationImmutable]
-> (RawPackageLocationImmutable
-> RIO env (PackageName, RawSnapshotPackage))
-> RIO env [(PackageName, RawSnapshotPackage)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [RawPackageLocationImmutable]
newPackages ((RawPackageLocationImmutable
-> RIO env (PackageName, RawSnapshotPackage))
-> RIO env [(PackageName, RawSnapshotPackage)])
-> (RawPackageLocationImmutable
-> RIO env (PackageName, RawSnapshotPackage))
-> RIO env [(PackageName, RawSnapshotPackage)]
forall a b. (a -> b) -> a -> b
$ \RawPackageLocationImmutable
loc -> do
PackageName
name <- RawPackageLocationImmutable -> RIO env PackageName
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageName
getPackageLocationName RawPackageLocationImmutable
loc
(PackageName, RawSnapshotPackage)
-> RIO env (PackageName, RawSnapshotPackage)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
name, RawSnapshotPackage
{ rspLocation :: RawPackageLocationImmutable
rspLocation = RawPackageLocationImmutable
loc
, rspFlags :: Map FlagName Bool
rspFlags = Map FlagName Bool
-> PackageName
-> Map PackageName (Map FlagName Bool)
-> Map FlagName Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map FlagName Bool
forall a. Monoid a => a
mempty PackageName
name Map PackageName (Map FlagName Bool)
flags
, rspHidden :: Bool
rspHidden = Bool -> PackageName -> Map PackageName Bool -> Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Bool
False PackageName
name Map PackageName Bool
hiddens
, rspGhcOptions :: [Text]
rspGhcOptions = [Text] -> PackageName -> Map PackageName [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] PackageName
name Map PackageName [Text]
options
})
let ([(PackageName, RawSnapshotPackage)]
newSingles, [(PackageName, [RawSnapshotPackage])]
newMultiples)
= [Either
(PackageName, RawSnapshotPackage)
(PackageName, [RawSnapshotPackage])]
-> ([(PackageName, RawSnapshotPackage)],
[(PackageName, [RawSnapshotPackage])])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
([Either
(PackageName, RawSnapshotPackage)
(PackageName, [RawSnapshotPackage])]
-> ([(PackageName, RawSnapshotPackage)],
[(PackageName, [RawSnapshotPackage])]))
-> [Either
(PackageName, RawSnapshotPackage)
(PackageName, [RawSnapshotPackage])]
-> ([(PackageName, RawSnapshotPackage)],
[(PackageName, [RawSnapshotPackage])])
forall a b. (a -> b) -> a -> b
$ ((PackageName, SingleOrNot RawSnapshotPackage)
-> Either
(PackageName, RawSnapshotPackage)
(PackageName, [RawSnapshotPackage]))
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
-> [Either
(PackageName, RawSnapshotPackage)
(PackageName, [RawSnapshotPackage])]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, SingleOrNot RawSnapshotPackage)
-> Either
(PackageName, RawSnapshotPackage)
(PackageName, [RawSnapshotPackage])
forall k a. (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither
([(PackageName, SingleOrNot RawSnapshotPackage)]
-> [Either
(PackageName, RawSnapshotPackage)
(PackageName, [RawSnapshotPackage])])
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
-> [Either
(PackageName, RawSnapshotPackage)
(PackageName, [RawSnapshotPackage])]
forall a b. (a -> b) -> a -> b
$ Map PackageName (SingleOrNot RawSnapshotPackage)
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
forall k a. Map k a -> [(k, a)]
Map.toList
(Map PackageName (SingleOrNot RawSnapshotPackage)
-> [(PackageName, SingleOrNot RawSnapshotPackage)])
-> Map PackageName (SingleOrNot RawSnapshotPackage)
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
forall a b. (a -> b) -> a -> b
$ (SingleOrNot RawSnapshotPackage
-> SingleOrNot RawSnapshotPackage
-> SingleOrNot RawSnapshotPackage)
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
-> Map PackageName (SingleOrNot RawSnapshotPackage)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith SingleOrNot RawSnapshotPackage
-> SingleOrNot RawSnapshotPackage -> SingleOrNot RawSnapshotPackage
forall a. Semigroup a => a -> a -> a
(<>)
([(PackageName, SingleOrNot RawSnapshotPackage)]
-> Map PackageName (SingleOrNot RawSnapshotPackage))
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
-> Map PackageName (SingleOrNot RawSnapshotPackage)
forall a b. (a -> b) -> a -> b
$ ((PackageName, RawSnapshotPackage)
-> (PackageName, SingleOrNot RawSnapshotPackage))
-> [(PackageName, RawSnapshotPackage)]
-> [(PackageName, SingleOrNot RawSnapshotPackage)]
forall a b. (a -> b) -> [a] -> [b]
map ((RawSnapshotPackage -> SingleOrNot RawSnapshotPackage)
-> (PackageName, RawSnapshotPackage)
-> (PackageName, SingleOrNot RawSnapshotPackage)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second RawSnapshotPackage -> SingleOrNot RawSnapshotPackage
forall a. a -> SingleOrNot a
Single) [(PackageName, RawSnapshotPackage)]
new'
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(PackageName, [RawSnapshotPackage])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, [RawSnapshotPackage])]
newMultiples) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
-> [(PackageName, [RawPackageLocationImmutable])]
-> PantryException
DuplicatePackageNames Utf8Builder
source ([(PackageName, [RawPackageLocationImmutable])] -> PantryException)
-> [(PackageName, [RawPackageLocationImmutable])]
-> PantryException
forall a b. (a -> b) -> a -> b
$ ((PackageName, [RawSnapshotPackage])
-> (PackageName, [RawPackageLocationImmutable]))
-> [(PackageName, [RawSnapshotPackage])]
-> [(PackageName, [RawPackageLocationImmutable])]
forall a b. (a -> b) -> [a] -> [b]
map (([RawSnapshotPackage] -> [RawPackageLocationImmutable])
-> (PackageName, [RawSnapshotPackage])
-> (PackageName, [RawPackageLocationImmutable])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((RawSnapshotPackage -> RawPackageLocationImmutable)
-> [RawSnapshotPackage] -> [RawPackageLocationImmutable]
forall a b. (a -> b) -> [a] -> [b]
map RawSnapshotPackage -> RawPackageLocationImmutable
rspLocation)) [(PackageName, [RawSnapshotPackage])]
newMultiples
let new :: Map PackageName RawSnapshotPackage
new = [(PackageName, RawSnapshotPackage)]
-> Map PackageName RawSnapshotPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, RawSnapshotPackage)]
newSingles
allPackages0 :: Map PackageName RawSnapshotPackage
allPackages0 = Map PackageName RawSnapshotPackage
new Map PackageName RawSnapshotPackage
-> Map PackageName RawSnapshotPackage
-> Map PackageName RawSnapshotPackage
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Map PackageName RawSnapshotPackage
old Map PackageName RawSnapshotPackage
-> Map PackageName () -> Map PackageName RawSnapshotPackage
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` (PackageName -> ()) -> Set PackageName -> Map PackageName ()
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (() -> PackageName -> ()
forall a b. a -> b -> a
const ()) Set PackageName
drops)
allPackages :: Map PackageName RawSnapshotPackage
allPackages = ((PackageName -> RawSnapshotPackage -> RawSnapshotPackage)
-> Map PackageName RawSnapshotPackage
-> Map PackageName RawSnapshotPackage)
-> Map PackageName RawSnapshotPackage
-> (PackageName -> RawSnapshotPackage -> RawSnapshotPackage)
-> Map PackageName RawSnapshotPackage
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PackageName -> RawSnapshotPackage -> RawSnapshotPackage)
-> Map PackageName RawSnapshotPackage
-> Map PackageName RawSnapshotPackage
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map PackageName RawSnapshotPackage
allPackages0 ((PackageName -> RawSnapshotPackage -> RawSnapshotPackage)
-> Map PackageName RawSnapshotPackage)
-> (PackageName -> RawSnapshotPackage -> RawSnapshotPackage)
-> Map PackageName RawSnapshotPackage
forall a b. (a -> b) -> a -> b
$ \PackageName
name RawSnapshotPackage
rsp ->
RawSnapshotPackage
rsp
{ rspFlags = Map.findWithDefault (rspFlags rsp) name flags
, rspHidden = Map.findWithDefault (rspHidden rsp) name hiddens
, rspGhcOptions = Map.findWithDefault (rspGhcOptions rsp) name options
}
unused :: AddPackagesConfig
unused = Set PackageName
-> Map PackageName (Map FlagName Bool)
-> Map PackageName Bool
-> Map PackageName [Text]
-> AddPackagesConfig
AddPackagesConfig
(Set PackageName
drops Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Map PackageName RawSnapshotPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName RawSnapshotPackage
old)
(Map PackageName (Map FlagName Bool)
flags Map PackageName (Map FlagName Bool)
-> Map PackageName RawSnapshotPackage
-> Map PackageName (Map FlagName Bool)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName RawSnapshotPackage
allPackages)
(Map PackageName Bool
hiddens Map PackageName Bool
-> Map PackageName RawSnapshotPackage -> Map PackageName Bool
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName RawSnapshotPackage
allPackages)
(Map PackageName [Text]
options Map PackageName [Text]
-> Map PackageName RawSnapshotPackage -> Map PackageName [Text]
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName RawSnapshotPackage
allPackages)
(Map PackageName RawSnapshotPackage, AddPackagesConfig)
-> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName RawSnapshotPackage
allPackages, AddPackagesConfig
unused)
cachedSnapshotCompletePackageLocation ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Map RawPackageLocationImmutable PackageLocationImmutable
-> RawPackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
cachedSnapshotCompletePackageLocation :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Map RawPackageLocationImmutable PackageLocationImmutable
-> RawPackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
cachedSnapshotCompletePackageLocation Map RawPackageLocationImmutable PackageLocationImmutable
cachePackages RawPackageLocationImmutable
rpli = MaybeT (RIO env) PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (RIO env) PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable))
-> MaybeT (RIO env) PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$
MaybeT (RIO env) PackageLocationImmutable
tryCache MaybeT (RIO env) PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable
forall a.
MaybeT (RIO env) a -> MaybeT (RIO env) a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT (RIO env) PackageLocationImmutable
tryCpl
where
tryCache :: MaybeT (RIO env) PackageLocationImmutable
tryCache = Maybe PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Maybe PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable)
-> Maybe PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> Maybe PackageLocationImmutable
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RawPackageLocationImmutable
rpli Map RawPackageLocationImmutable PackageLocationImmutable
cachePackages
tryCpl :: MaybeT (RIO env) PackageLocationImmutable
tryCpl = do
CompletePackageLocation
cpl <- RIO env CompletePackageLocation
-> MaybeT (RIO env) CompletePackageLocation
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env CompletePackageLocation
-> MaybeT (RIO env) CompletePackageLocation)
-> RIO env CompletePackageLocation
-> MaybeT (RIO env) CompletePackageLocation
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> RIO env CompletePackageLocation
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation RawPackageLocationImmutable
rpli
if CompletePackageLocation -> Bool
cplHasCabalFile CompletePackageLocation
cpl then PackageLocationImmutable
-> MaybeT (RIO env) PackageLocationImmutable
forall a. a -> MaybeT (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl) else MaybeT (RIO env) PackageLocationImmutable
forall a. MaybeT (RIO env) a
forall (f :: * -> *) a. Alternative f => f a
empty
addAndCompletePackagesToSnapshot ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawSnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName SnapshotPackage
-> RIO
env
(Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig)
addAndCompletePackagesToSnapshot :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName SnapshotPackage
-> RIO
env
(Map PackageName SnapshotPackage, [CompletedPLI],
AddPackagesConfig)
addAndCompletePackagesToSnapshot RawSnapshotLocation
loc Map RawPackageLocationImmutable PackageLocationImmutable
cachedPL [RawPackageLocationImmutable]
newPackages (AddPackagesConfig Set PackageName
drops Map PackageName (Map FlagName Bool)
flags Map PackageName Bool
hiddens Map PackageName [Text]
options) Map PackageName SnapshotPackage
old = do
let source :: Utf8Builder
source = RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
loc
addPackage ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> ([(PackageName, SnapshotPackage)],[CompletedPLI])
-> RawPackageLocationImmutable
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
addPackage :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RawPackageLocationImmutable
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
addPackage ([(PackageName, SnapshotPackage)]
ps, [CompletedPLI]
completed) RawPackageLocationImmutable
rawLoc = do
Maybe PackageLocationImmutable
mcomplLoc <- Map RawPackageLocationImmutable PackageLocationImmutable
-> RawPackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Map RawPackageLocationImmutable PackageLocationImmutable
-> RawPackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
cachedSnapshotCompletePackageLocation Map RawPackageLocationImmutable PackageLocationImmutable
cachedPL RawPackageLocationImmutable
rawLoc
case Maybe PackageLocationImmutable
mcomplLoc of
Maybe PackageLocationImmutable
Nothing -> do
RawPackageLocationImmutable -> RIO env ()
forall env.
HasLogFunc env =>
RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile RawPackageLocationImmutable
rawLoc
([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PackageName, SnapshotPackage)]
ps, [CompletedPLI]
completed)
Just PackageLocationImmutable
complLoc -> do
let PackageIdentifier PackageName
name Version
_ = PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
complLoc
p :: (PackageName, SnapshotPackage)
p = (PackageName
name, SnapshotPackage
{ spLocation :: PackageLocationImmutable
spLocation = PackageLocationImmutable
complLoc
, spFlags :: Map FlagName Bool
spFlags = Map FlagName Bool
-> PackageName
-> Map PackageName (Map FlagName Bool)
-> Map FlagName Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map FlagName Bool
forall a. Monoid a => a
mempty PackageName
name Map PackageName (Map FlagName Bool)
flags
, spHidden :: Bool
spHidden = Bool -> PackageName -> Map PackageName Bool -> Bool
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Bool
False PackageName
name Map PackageName Bool
hiddens
, spGhcOptions :: [Text]
spGhcOptions = [Text] -> PackageName -> Map PackageName [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] PackageName
name Map PackageName [Text]
options
})
completed' :: [CompletedPLI]
completed' = if PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
complLoc RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
forall a. Eq a => a -> a -> Bool
== RawPackageLocationImmutable
rawLoc
then [CompletedPLI]
completed
else RawPackageLocationImmutable
-> PackageLocationImmutable -> CompletedPLI
CompletedPLI RawPackageLocationImmutable
rawLoc PackageLocationImmutable
complLocCompletedPLI -> [CompletedPLI] -> [CompletedPLI]
forall a. a -> [a] -> [a]
:[CompletedPLI]
completed
([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PackageName, SnapshotPackage)
p(PackageName, SnapshotPackage)
-> [(PackageName, SnapshotPackage)]
-> [(PackageName, SnapshotPackage)]
forall a. a -> [a] -> [a]
:[(PackageName, SnapshotPackage)]
ps, [CompletedPLI]
completed')
([(PackageName, SnapshotPackage)]
revNew, [CompletedPLI]
revCompleted) <- (([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RawPackageLocationImmutable
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]))
-> ([(PackageName, SnapshotPackage)], [CompletedPLI])
-> [RawPackageLocationImmutable]
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RawPackageLocationImmutable
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
([(PackageName, SnapshotPackage)], [CompletedPLI])
-> RawPackageLocationImmutable
-> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI])
addPackage ([], []) [RawPackageLocationImmutable]
newPackages
let ([(PackageName, SnapshotPackage)]
newSingles, [(PackageName, [SnapshotPackage])]
newMultiples)
= [Either
(PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])]
-> ([(PackageName, SnapshotPackage)],
[(PackageName, [SnapshotPackage])])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
([Either
(PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])]
-> ([(PackageName, SnapshotPackage)],
[(PackageName, [SnapshotPackage])]))
-> [Either
(PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])]
-> ([(PackageName, SnapshotPackage)],
[(PackageName, [SnapshotPackage])])
forall a b. (a -> b) -> a -> b
$ ((PackageName, SingleOrNot SnapshotPackage)
-> Either
(PackageName, SnapshotPackage) (PackageName, [SnapshotPackage]))
-> [(PackageName, SingleOrNot SnapshotPackage)]
-> [Either
(PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, SingleOrNot SnapshotPackage)
-> Either
(PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])
forall k a. (k, SingleOrNot a) -> Either (k, a) (k, [a])
sonToEither
([(PackageName, SingleOrNot SnapshotPackage)]
-> [Either
(PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])])
-> [(PackageName, SingleOrNot SnapshotPackage)]
-> [Either
(PackageName, SnapshotPackage) (PackageName, [SnapshotPackage])]
forall a b. (a -> b) -> a -> b
$ Map PackageName (SingleOrNot SnapshotPackage)
-> [(PackageName, SingleOrNot SnapshotPackage)]
forall k a. Map k a -> [(k, a)]
Map.toList
(Map PackageName (SingleOrNot SnapshotPackage)
-> [(PackageName, SingleOrNot SnapshotPackage)])
-> Map PackageName (SingleOrNot SnapshotPackage)
-> [(PackageName, SingleOrNot SnapshotPackage)]
forall a b. (a -> b) -> a -> b
$ (SingleOrNot SnapshotPackage
-> SingleOrNot SnapshotPackage -> SingleOrNot SnapshotPackage)
-> [(PackageName, SingleOrNot SnapshotPackage)]
-> Map PackageName (SingleOrNot SnapshotPackage)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith SingleOrNot SnapshotPackage
-> SingleOrNot SnapshotPackage -> SingleOrNot SnapshotPackage
forall a. Semigroup a => a -> a -> a
(<>)
([(PackageName, SingleOrNot SnapshotPackage)]
-> Map PackageName (SingleOrNot SnapshotPackage))
-> [(PackageName, SingleOrNot SnapshotPackage)]
-> Map PackageName (SingleOrNot SnapshotPackage)
forall a b. (a -> b) -> a -> b
$ ((PackageName, SnapshotPackage)
-> (PackageName, SingleOrNot SnapshotPackage))
-> [(PackageName, SnapshotPackage)]
-> [(PackageName, SingleOrNot SnapshotPackage)]
forall a b. (a -> b) -> [a] -> [b]
map ((SnapshotPackage -> SingleOrNot SnapshotPackage)
-> (PackageName, SnapshotPackage)
-> (PackageName, SingleOrNot SnapshotPackage)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SnapshotPackage -> SingleOrNot SnapshotPackage
forall a. a -> SingleOrNot a
Single) ([(PackageName, SnapshotPackage)]
-> [(PackageName, SnapshotPackage)]
forall a. [a] -> [a]
reverse [(PackageName, SnapshotPackage)]
revNew)
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(PackageName, [SnapshotPackage])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, [SnapshotPackage])]
newMultiples) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
-> [(PackageName, [RawPackageLocationImmutable])]
-> PantryException
DuplicatePackageNames Utf8Builder
source ([(PackageName, [RawPackageLocationImmutable])] -> PantryException)
-> [(PackageName, [RawPackageLocationImmutable])]
-> PantryException
forall a b. (a -> b) -> a -> b
$ ((PackageName, [SnapshotPackage])
-> (PackageName, [RawPackageLocationImmutable]))
-> [(PackageName, [SnapshotPackage])]
-> [(PackageName, [RawPackageLocationImmutable])]
forall a b. (a -> b) -> [a] -> [b]
map (([SnapshotPackage] -> [RawPackageLocationImmutable])
-> (PackageName, [SnapshotPackage])
-> (PackageName, [RawPackageLocationImmutable])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((SnapshotPackage -> RawPackageLocationImmutable)
-> [SnapshotPackage] -> [RawPackageLocationImmutable]
forall a b. (a -> b) -> [a] -> [b]
map (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (PackageLocationImmutable -> RawPackageLocationImmutable)
-> (SnapshotPackage -> PackageLocationImmutable)
-> SnapshotPackage
-> RawPackageLocationImmutable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotPackage -> PackageLocationImmutable
spLocation))) [(PackageName, [SnapshotPackage])]
newMultiples
let new :: Map PackageName SnapshotPackage
new = [(PackageName, SnapshotPackage)] -> Map PackageName SnapshotPackage
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, SnapshotPackage)]
newSingles
allPackages0 :: Map PackageName SnapshotPackage
allPackages0 = Map PackageName SnapshotPackage
new Map PackageName SnapshotPackage
-> Map PackageName SnapshotPackage
-> Map PackageName SnapshotPackage
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` (Map PackageName SnapshotPackage
old Map PackageName SnapshotPackage
-> Map PackageName () -> Map PackageName SnapshotPackage
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` (PackageName -> ()) -> Set PackageName -> Map PackageName ()
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (() -> PackageName -> ()
forall a b. a -> b -> a
const ()) Set PackageName
drops)
allPackages :: Map PackageName SnapshotPackage
allPackages = ((PackageName -> SnapshotPackage -> SnapshotPackage)
-> Map PackageName SnapshotPackage
-> Map PackageName SnapshotPackage)
-> Map PackageName SnapshotPackage
-> (PackageName -> SnapshotPackage -> SnapshotPackage)
-> Map PackageName SnapshotPackage
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PackageName -> SnapshotPackage -> SnapshotPackage)
-> Map PackageName SnapshotPackage
-> Map PackageName SnapshotPackage
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map PackageName SnapshotPackage
allPackages0 ((PackageName -> SnapshotPackage -> SnapshotPackage)
-> Map PackageName SnapshotPackage)
-> (PackageName -> SnapshotPackage -> SnapshotPackage)
-> Map PackageName SnapshotPackage
forall a b. (a -> b) -> a -> b
$ \PackageName
name SnapshotPackage
sp ->
SnapshotPackage
sp
{ spFlags = Map.findWithDefault (spFlags sp) name flags
, spHidden = Map.findWithDefault (spHidden sp) name hiddens
, spGhcOptions = Map.findWithDefault (spGhcOptions sp) name options
}
unused :: AddPackagesConfig
unused = Set PackageName
-> Map PackageName (Map FlagName Bool)
-> Map PackageName Bool
-> Map PackageName [Text]
-> AddPackagesConfig
AddPackagesConfig
(Set PackageName
drops Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Map PackageName SnapshotPackage -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName SnapshotPackage
old)
(Map PackageName (Map FlagName Bool)
flags Map PackageName (Map FlagName Bool)
-> Map PackageName SnapshotPackage
-> Map PackageName (Map FlagName Bool)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName SnapshotPackage
allPackages)
(Map PackageName Bool
hiddens Map PackageName Bool
-> Map PackageName SnapshotPackage -> Map PackageName Bool
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName SnapshotPackage
allPackages)
(Map PackageName [Text]
options Map PackageName [Text]
-> Map PackageName SnapshotPackage -> Map PackageName [Text]
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`Map.difference` Map PackageName SnapshotPackage
allPackages)
(Map PackageName SnapshotPackage, [CompletedPLI],
AddPackagesConfig)
-> RIO
env
(Map PackageName SnapshotPackage, [CompletedPLI],
AddPackagesConfig)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName SnapshotPackage
allPackages, [CompletedPLI] -> [CompletedPLI]
forall a. [a] -> [a]
reverse [CompletedPLI]
revCompleted, AddPackagesConfig
unused)
loadRawSnapshotLayer ::
(HasPantryConfig env, HasLogFunc env)
=> RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer (RSLCompiler WantedCompiler
compiler) = Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ WantedCompiler
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall a b. a -> Either a b
Left WantedCompiler
compiler
loadRawSnapshotLayer rsl :: RawSnapshotLocation
rsl@(RSLUrl Text
url Maybe BlobKey
blob) =
(SomeException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (PantryException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> (SomeException -> PantryException)
-> SomeException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot RawSnapshotLocation
rsl) (RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ do
ByteString
bs <- Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url Maybe BlobKey
blob
Value
value <- ByteString -> RIO env Value
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow ByteString
bs
RawSnapshotLayer
snapshot <- RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall env.
HasLogFunc env =>
RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelperRaw RawSnapshotLocation
rsl Value
value Maybe (Path Abs Dir)
forall a. Maybe a
Nothing
Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ (RawSnapshotLayer, CompletedSL)
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall a b. b -> Either a b
Right (RawSnapshotLayer
snapshot, RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL RawSnapshotLocation
rsl (Text -> BlobKey -> SnapshotLocation
SLUrl Text
url (ByteString -> BlobKey
bsToBlobKey ByteString
bs)))
loadRawSnapshotLayer rsl :: RawSnapshotLocation
rsl@(RSLFilePath ResolvedPath File
fp) =
(SomeException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (PantryException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> (SomeException -> PantryException)
-> SomeException
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot RawSnapshotLocation
rsl) (RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ do
Value
value <- String -> RIO env Value
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow (String -> RIO env Value) -> String -> RIO env Value
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String) -> Path Abs File -> String
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
RawSnapshotLayer
snapshot <- RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall env.
HasLogFunc env =>
RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelperRaw RawSnapshotLocation
rsl Value
value (Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer)
-> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just (Path Abs Dir -> Maybe (Path Abs Dir))
-> Path Abs Dir -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ (RawSnapshotLayer, CompletedSL)
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall a b. b -> Either a b
Right (RawSnapshotLayer
snapshot, RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL RawSnapshotLocation
rsl (ResolvedPath File -> SnapshotLocation
SLFilePath ResolvedPath File
fp))
loadRawSnapshotLayer rsl :: RawSnapshotLocation
rsl@(RSLSynonym SnapName
syn) = do
RawSnapshotLocation
loc <- SnapName -> RIO env RawSnapshotLocation
forall env.
HasPantryConfig env =>
SnapName -> RIO env RawSnapshotLocation
snapshotLocation SnapName
syn
Either WantedCompiler (RawSnapshotLayer, CompletedSL)
comp <- RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer RawSnapshotLocation
loc
Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)))
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
forall a b. (a -> b) -> a -> b
$ case Either WantedCompiler (RawSnapshotLayer, CompletedSL)
comp of
Left WantedCompiler
wc -> WantedCompiler
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall a b. a -> Either a b
Left WantedCompiler
wc
Right (RawSnapshotLayer
l, CompletedSL RawSnapshotLocation
_ SnapshotLocation
n) -> (RawSnapshotLayer, CompletedSL)
-> Either WantedCompiler (RawSnapshotLayer, CompletedSL)
forall a b. b -> Either a b
Right (RawSnapshotLayer
l, RawSnapshotLocation -> SnapshotLocation -> CompletedSL
CompletedSL RawSnapshotLocation
rsl SnapshotLocation
n)
loadSnapshotLayer ::
(HasPantryConfig env, HasLogFunc env)
=> SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer (SLCompiler WantedCompiler
compiler) = Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer))
-> Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Either WantedCompiler RawSnapshotLayer
forall a b. a -> Either a b
Left WantedCompiler
compiler
loadSnapshotLayer sl :: SnapshotLocation
sl@(SLUrl Text
url BlobKey
blob) =
(SomeException -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (PantryException -> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException
-> RIO env (Either WantedCompiler RawSnapshotLayer))
-> (SomeException -> PantryException)
-> SomeException
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl)) (RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ do
ByteString
bs <- Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url (BlobKey -> Maybe BlobKey
forall a. a -> Maybe a
Just BlobKey
blob)
Value
value <- ByteString -> RIO env Value
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow ByteString
bs
RawSnapshotLayer
snapshot <- SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall env.
HasLogFunc env =>
SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
value Maybe (Path Abs Dir)
forall a. Maybe a
Nothing
Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer))
-> Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> Either WantedCompiler RawSnapshotLayer
forall a b. b -> Either a b
Right RawSnapshotLayer
snapshot
loadSnapshotLayer sl :: SnapshotLocation
sl@(SLFilePath ResolvedPath File
fp) =
(SomeException -> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (PantryException -> RIO env (Either WantedCompiler RawSnapshotLayer)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException
-> RIO env (Either WantedCompiler RawSnapshotLayer))
-> (SomeException -> PantryException)
-> SomeException
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawSnapshotLocation -> SomeException -> PantryException
InvalidSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl)) (RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer))
-> RIO env (Either WantedCompiler RawSnapshotLayer)
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ do
Value
value <- String -> RIO env Value
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow (String -> RIO env Value) -> String -> RIO env Value
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String) -> Path Abs File -> String
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
RawSnapshotLayer
snapshot <- SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall env.
HasLogFunc env =>
SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
value (Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer)
-> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just (Path Abs Dir -> Maybe (Path Abs Dir))
-> Path Abs Dir -> Maybe (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer))
-> Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> Either WantedCompiler RawSnapshotLayer
forall a b. b -> Either a b
Right RawSnapshotLayer
snapshot
loadFromURL ::
(HasPantryConfig env, HasLogFunc env)
=> Text
-> Maybe BlobKey
-> RIO env ByteString
loadFromURL :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadFromURL Text
url Maybe BlobKey
Nothing = do
Maybe ByteString
mcached <- ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString))
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall env. Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadURLBlob Text
url
case Maybe ByteString
mcached of
Just ByteString
bs -> ByteString -> RIO env ByteString
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
Maybe ByteString
Nothing -> Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadWithCheck Text
url Maybe BlobKey
forall a. Maybe a
Nothing
loadFromURL Text
url (Just BlobKey
bkey) = do
Maybe ByteString
mcached <- ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString))
-> ReaderT SqlBackend (RIO env) (Maybe ByteString)
-> RIO env (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
forall env.
HasLogFunc env =>
BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString)
loadBlob BlobKey
bkey
case Maybe ByteString
mcached of
Just ByteString
bs -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Loaded snapshot from Pantry database."
ByteString -> RIO env ByteString
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
Maybe ByteString
Nothing -> Text -> BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> BlobKey -> RIO env ByteString
loadUrlViaCasaOrWithCheck Text
url BlobKey
bkey
loadUrlViaCasaOrWithCheck ::
(HasPantryConfig env, HasLogFunc env)
=> Text
-> BlobKey
-> RIO env ByteString
loadUrlViaCasaOrWithCheck :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> BlobKey -> RIO env ByteString
loadUrlViaCasaOrWithCheck Text
url BlobKey
blobKey = do
Maybe ByteString
mblobFromCasa <- BlobKey -> RIO env (Maybe ByteString)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
BlobKey -> RIO env (Maybe ByteString)
casaLookupKey BlobKey
blobKey
case Maybe ByteString
mblobFromCasa of
Just ByteString
blob -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug
(Utf8Builder
"Loaded snapshot from Casa (" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> BlobKey -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display BlobKey
blobKey Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
") for URL: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url)
ByteString -> RIO env ByteString
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
blob
Maybe ByteString
Nothing -> Text -> Maybe BlobKey -> RIO env ByteString
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadWithCheck Text
url (BlobKey -> Maybe BlobKey
forall a. a -> Maybe a
Just BlobKey
blobKey)
loadWithCheck ::
(HasPantryConfig env, HasLogFunc env)
=> Text
-> Maybe BlobKey
-> RIO env ByteString
loadWithCheck :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Text -> Maybe BlobKey -> RIO env ByteString
loadWithCheck Text
url Maybe BlobKey
mblobkey = do
let (Maybe SHA256
msha, Maybe FileSize
msize) =
case Maybe BlobKey
mblobkey of
Maybe BlobKey
Nothing -> (Maybe SHA256
forall a. Maybe a
Nothing, Maybe FileSize
forall a. Maybe a
Nothing)
Just (BlobKey SHA256
sha FileSize
size) -> (SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
sha, FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)
(SHA256
_, FileSize
_, [ByteString]
bss) <- Text
-> Maybe SHA256
-> Maybe FileSize
-> ConduitT ByteString Void (RIO env) [ByteString]
-> RIO env (SHA256, FileSize, [ByteString])
forall (m :: * -> *) a.
MonadUnliftIO m =>
Text
-> Maybe SHA256
-> Maybe FileSize
-> ConduitT ByteString Void m a
-> m (SHA256, FileSize, a)
httpSinkChecked Text
url Maybe SHA256
msha Maybe FileSize
msize ConduitT ByteString Void (RIO env) [ByteString]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
let bs :: ByteString
bs = [ByteString] -> ByteString
B.concat [ByteString]
bss
ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> ByteString -> ReaderT SqlBackend (RIO env) ()
forall env. Text -> ByteString -> ReaderT SqlBackend (RIO env) ()
storeURLBlob Text
url ByteString
bs
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Loaded snapshot from third party: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
url)
ByteString -> RIO env ByteString
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
warningsParserHelperRaw ::
HasLogFunc env
=> RawSnapshotLocation
-> Value
-> Maybe (Path Abs Dir)
-> RIO env RawSnapshotLayer
warningsParserHelperRaw :: forall env.
HasLogFunc env =>
RawSnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelperRaw RawSnapshotLocation
rsl Value
val Maybe (Path Abs Dir)
mdir =
case (Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer)))
-> Value
-> Either String (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a. FromJSON a => Value -> Parser a
Yaml.parseJSON Value
val of
Left String
e -> PantryException -> RIO env RawSnapshotLayer
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env RawSnapshotLayer)
-> PantryException -> RIO env RawSnapshotLayer
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> String -> PantryException
Couldn'tParseSnapshot RawSnapshotLocation
rsl String
e
Right (WithJSONWarnings Unresolved RawSnapshotLayer
x [JSONWarning]
ws) -> do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([JSONWarning] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JSONWarning]
ws) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warnings when parsing snapshot " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
rsl
[JSONWarning] -> (JSONWarning -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [JSONWarning]
ws ((JSONWarning -> RIO env ()) -> RIO env ())
-> (JSONWarning -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (JSONWarning -> Utf8Builder) -> JSONWarning -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONWarning -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display
Maybe (Path Abs Dir)
-> Unresolved RawSnapshotLayer -> RIO env RawSnapshotLayer
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths Maybe (Path Abs Dir)
mdir Unresolved RawSnapshotLayer
x
warningsParserHelper ::
HasLogFunc env
=> SnapshotLocation
-> Value
-> Maybe (Path Abs Dir)
-> RIO env RawSnapshotLayer
warningsParserHelper :: forall env.
HasLogFunc env =>
SnapshotLocation
-> Value -> Maybe (Path Abs Dir) -> RIO env RawSnapshotLayer
warningsParserHelper SnapshotLocation
sl Value
val Maybe (Path Abs Dir)
mdir =
case (Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer)))
-> Value
-> Either String (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a. FromJSON a => Value -> Parser a
Yaml.parseJSON Value
val of
Left String
e -> PantryException -> RIO env RawSnapshotLayer
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env RawSnapshotLayer)
-> PantryException -> RIO env RawSnapshotLayer
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> String -> PantryException
Couldn'tParseSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl) String
e
Right (WithJSONWarnings Unresolved RawSnapshotLayer
x [JSONWarning]
ws) -> do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([JSONWarning] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JSONWarning]
ws) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Warnings when parsing snapshot " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SnapshotLocation
sl
[JSONWarning] -> (JSONWarning -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [JSONWarning]
ws ((JSONWarning -> RIO env ()) -> RIO env ())
-> (JSONWarning -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (JSONWarning -> Utf8Builder) -> JSONWarning -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONWarning -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display
Maybe (Path Abs Dir)
-> Unresolved RawSnapshotLayer -> RIO env RawSnapshotLayer
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths Maybe (Path Abs Dir)
mdir Unresolved RawSnapshotLayer
x
getPackageLocationName ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RIO env PackageName
getPackageLocationName :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageName
getPackageLocationName = (PackageIdentifier -> PackageName)
-> RIO env PackageIdentifier -> RIO env PackageName
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageIdentifier -> PackageName
pkgName (RIO env PackageIdentifier -> RIO env PackageName)
-> (RawPackageLocationImmutable -> RIO env PackageIdentifier)
-> RawPackageLocationImmutable
-> RIO env PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawPackageLocationImmutable -> RIO env PackageIdentifier
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent
packageLocationIdent ::
PackageLocationImmutable
-> PackageIdentifier
packageLocationIdent :: PackageLocationImmutable -> PackageIdentifier
packageLocationIdent (PLIHackage PackageIdentifier
ident BlobKey
_ TreeKey
_) = PackageIdentifier
ident
packageLocationIdent (PLIRepo Repo
_ PackageMetadata
pm) = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm
packageLocationIdent (PLIArchive Archive
_ PackageMetadata
pm) = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm
packageLocationVersion ::
PackageLocationImmutable
-> Version
packageLocationVersion :: PackageLocationImmutable -> Version
packageLocationVersion (PLIHackage PackageIdentifier
pident BlobKey
_ TreeKey
_) = PackageIdentifier -> Version
pkgVersion PackageIdentifier
pident
packageLocationVersion (PLIRepo Repo
_ PackageMetadata
pm) = PackageIdentifier -> Version
pkgVersion (PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm)
packageLocationVersion (PLIArchive Archive
_ PackageMetadata
pm) = PackageIdentifier -> Version
pkgVersion (PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm)
getRawPackageLocationIdent ::
(HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RIO env PackageIdentifier
getRawPackageLocationIdent :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
_) Maybe TreeKey
_) =
PackageIdentifier -> RIO env PackageIdentifier
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier -> RIO env PackageIdentifier)
-> PackageIdentifier -> RIO env PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
getRawPackageLocationIdent (RPLIRepo Repo
_ RawPackageMetadata { rpmName :: RawPackageMetadata -> Maybe PackageName
rpmName = Just PackageName
name, rpmVersion :: RawPackageMetadata -> Maybe Version
rpmVersion = Just Version
version }) =
PackageIdentifier -> RIO env PackageIdentifier
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier -> RIO env PackageIdentifier)
-> PackageIdentifier -> RIO env PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
getRawPackageLocationIdent (RPLIArchive RawArchive
_ RawPackageMetadata { rpmName :: RawPackageMetadata -> Maybe PackageName
rpmName = Just PackageName
name, rpmVersion :: RawPackageMetadata -> Maybe Version
rpmVersion = Just Version
version }) =
PackageIdentifier -> RIO env PackageIdentifier
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier -> RIO env PackageIdentifier)
-> PackageIdentifier -> RIO env PackageIdentifier
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
getRawPackageLocationIdent RawPackageLocationImmutable
rpli = Package -> PackageIdentifier
packageIdent (Package -> PackageIdentifier)
-> RIO env Package -> RIO env PackageIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageLocationImmutable -> RIO env Package
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env Package
loadPackageRaw RawPackageLocationImmutable
rpli
getRawPackageLocationTreeKey
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RIO env TreeKey
getRawPackageLocationTreeKey :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env TreeKey
getRawPackageLocationTreeKey RawPackageLocationImmutable
pl =
case RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey RawPackageLocationImmutable
pl of
Just TreeKey
treeKey' -> TreeKey -> RIO env TreeKey
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TreeKey
treeKey'
Maybe TreeKey
Nothing ->
case RawPackageLocationImmutable
pl of
RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_ -> PackageIdentifierRevision -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey PackageIdentifierRevision
pir
RPLIArchive RawArchive
archive RawPackageMetadata
pm -> RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> RawArchive -> RawPackageMetadata -> RIO env TreeKey
getArchiveKey RawPackageLocationImmutable
pl RawArchive
archive RawPackageMetadata
pm
RPLIRepo Repo
repo RawPackageMetadata
pm -> Repo -> RawPackageMetadata -> RIO env TreeKey
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Repo -> RawPackageMetadata -> RIO env TreeKey
getRepoKey Repo
repo RawPackageMetadata
pm
getPackageLocationTreeKey
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> PackageLocationImmutable
-> RIO env TreeKey
getPackageLocationTreeKey :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env TreeKey
getPackageLocationTreeKey PackageLocationImmutable
pl = TreeKey -> RIO env TreeKey
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TreeKey -> RIO env TreeKey) -> TreeKey -> RIO env TreeKey
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> TreeKey
getTreeKey PackageLocationImmutable
pl
getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey (RPLIHackage PackageIdentifierRevision
_ Maybe TreeKey
mtree) = Maybe TreeKey
mtree
getRawTreeKey (RPLIArchive RawArchive
_ RawPackageMetadata
rpm) = RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm
getRawTreeKey (RPLIRepo Repo
_ RawPackageMetadata
rpm) = RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm
getTreeKey :: PackageLocationImmutable -> TreeKey
getTreeKey :: PackageLocationImmutable -> TreeKey
getTreeKey (PLIHackage PackageIdentifier
_ BlobKey
_ TreeKey
tree) = TreeKey
tree
getTreeKey (PLIArchive Archive
_ PackageMetadata
pm) = PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm
getTreeKey (PLIRepo Repo
_ PackageMetadata
pm) = PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm
data PantryApp = PantryApp
{ PantryApp -> SimpleApp
paSimpleApp :: !SimpleApp
, PantryApp -> PantryConfig
paPantryConfig :: !PantryConfig
, PantryApp -> Bool
paUseColor :: !Bool
, PantryApp -> Int
paTermWidth :: !Int
, PantryApp -> StylesUpdate
paStylesUpdate :: !StylesUpdate
}
simpleAppL :: Lens' PantryApp SimpleApp
simpleAppL :: Lens' PantryApp SimpleApp
simpleAppL = (PantryApp -> SimpleApp)
-> (PantryApp -> SimpleApp -> PantryApp)
-> Lens' PantryApp SimpleApp
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> SimpleApp
paSimpleApp (\PantryApp
x SimpleApp
y -> PantryApp
x { paSimpleApp = y })
hpackExecutableL :: Lens' PantryConfig HpackExecutable
hpackExecutableL :: Lens' PantryConfig HpackExecutable
hpackExecutableL HpackExecutable -> f HpackExecutable
k PantryConfig
pconfig =
(HpackExecutable -> PantryConfig)
-> f HpackExecutable -> f PantryConfig
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HpackExecutable
hpExe -> PantryConfig
pconfig { pcHpackExecutable = hpExe }) (HpackExecutable -> f HpackExecutable
k (PantryConfig -> HpackExecutable
pcHpackExecutable PantryConfig
pconfig))
hpackForceL :: Lens' PantryConfig Hpack.Force
hpackForceL :: Lens' PantryConfig Force
hpackForceL Force -> f Force
k PantryConfig
pconfig =
(Force -> PantryConfig) -> f Force -> f PantryConfig
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(\Force
hpackForce -> PantryConfig
pconfig { pcHpackForce = hpackForce })
(Force -> f Force
k (PantryConfig -> Force
pcHpackForce PantryConfig
pconfig))
instance HasLogFunc PantryApp where
logFuncL :: Lens' PantryApp LogFunc
logFuncL = (SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp
Lens' PantryApp SimpleApp
simpleAppL((SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp)
-> ((LogFunc -> f LogFunc) -> SimpleApp -> f SimpleApp)
-> (LogFunc -> f LogFunc)
-> PantryApp
-> f PantryApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogFunc -> f LogFunc) -> SimpleApp -> f SimpleApp
forall env. HasLogFunc env => Lens' env LogFunc
Lens' SimpleApp LogFunc
logFuncL
instance HasPantryConfig PantryApp where
pantryConfigL :: Lens' PantryApp PantryConfig
pantryConfigL = (PantryApp -> PantryConfig)
-> (PantryApp -> PantryConfig -> PantryApp)
-> Lens' PantryApp PantryConfig
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> PantryConfig
paPantryConfig (\PantryApp
x PantryConfig
y -> PantryApp
x { paPantryConfig = y })
instance HasProcessContext PantryApp where
processContextL :: Lens' PantryApp ProcessContext
processContextL = (SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp
Lens' PantryApp SimpleApp
simpleAppL((SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp)
-> ((ProcessContext -> f ProcessContext)
-> SimpleApp -> f SimpleApp)
-> (ProcessContext -> f ProcessContext)
-> PantryApp
-> f PantryApp
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ProcessContext -> f ProcessContext) -> SimpleApp -> f SimpleApp
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' SimpleApp ProcessContext
processContextL
instance HasStylesUpdate PantryApp where
stylesUpdateL :: Lens' PantryApp StylesUpdate
stylesUpdateL = (PantryApp -> StylesUpdate)
-> (PantryApp -> StylesUpdate -> PantryApp)
-> Lens' PantryApp StylesUpdate
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> StylesUpdate
paStylesUpdate (\PantryApp
x StylesUpdate
y -> PantryApp
x { paStylesUpdate = y })
instance HasTerm PantryApp where
useColorL :: Lens' PantryApp Bool
useColorL = (PantryApp -> Bool)
-> (PantryApp -> Bool -> PantryApp) -> Lens' PantryApp Bool
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> Bool
paUseColor (\PantryApp
x Bool
y -> PantryApp
x { paUseColor = y })
termWidthL :: Lens' PantryApp Int
termWidthL = (PantryApp -> Int)
-> (PantryApp -> Int -> PantryApp) -> Lens' PantryApp Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens PantryApp -> Int
paTermWidth (\PantryApp
x Int
y -> PantryApp
x { paTermWidth = y })
runPantryApp :: MonadIO m => RIO PantryApp a -> m a
runPantryApp :: forall (m :: * -> *) a. MonadIO m => RIO PantryApp a -> m a
runPantryApp = Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
forall (m :: * -> *) a.
MonadIO m =>
Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
runPantryAppWith Int
8 CasaRepoPrefix
defaultCasaRepoPrefix Int
defaultCasaMaxPerRequest
runPantryAppWith ::
MonadIO m
=> Int
-> CasaRepoPrefix
-> Int
-> RIO PantryApp a
-> m a
runPantryAppWith :: forall (m :: * -> *) a.
MonadIO m =>
Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a
runPantryAppWith Int
maxConnCount CasaRepoPrefix
casaRepoPrefix Int
casaMaxPerRequest RIO PantryApp a
f = RIO SimpleApp a -> m a
forall (m :: * -> *) a. MonadIO m => RIO SimpleApp a -> m a
runSimpleApp (RIO SimpleApp a -> m a) -> RIO SimpleApp a -> m a
forall a b. (a -> b) -> a -> b
$ do
SimpleApp
sa <- RIO SimpleApp SimpleApp
forall r (m :: * -> *). MonadReader r m => m r
ask
String
stack <- String -> RIO SimpleApp String
forall (m :: * -> *). MonadIO m => String -> m String
getAppUserDataDirectory String
"stack"
Path Abs Dir
root <- String -> RIO SimpleApp (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir (String -> RIO SimpleApp (Path Abs Dir))
-> String -> RIO SimpleApp (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ String
stack String -> String -> String
FilePath.</> String
"pantry"
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO SimpleApp a)
-> RIO SimpleApp a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig'
Path Abs Dir
root
PackageIndexConfig
defaultPackageIndexConfig
HpackExecutable
HpackBundled
Force
Hpack.NoForce
Int
maxConnCount
((CasaRepoPrefix, Int) -> Maybe (CasaRepoPrefix, Int)
forall a. a -> Maybe a
Just (CasaRepoPrefix
casaRepoPrefix, Int
casaMaxPerRequest))
SnapName -> RawSnapshotLocation
defaultSnapshotLocation
WantedCompiler -> GlobalHintsLocation
defaultGlobalHintsLocation
((PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a)
-> (PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a
forall a b. (a -> b) -> a -> b
$ \PantryConfig
pc ->
PantryApp -> RIO PantryApp a -> RIO SimpleApp a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
PantryApp
{ paSimpleApp :: SimpleApp
paSimpleApp = SimpleApp
sa
, paPantryConfig :: PantryConfig
paPantryConfig = PantryConfig
pc
, paTermWidth :: Int
paTermWidth = Int
100
, paUseColor :: Bool
paUseColor = Bool
True
, paStylesUpdate :: StylesUpdate
paStylesUpdate = StylesUpdate
forall a. Monoid a => a
mempty
}
RIO PantryApp a
f
runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a
runPantryAppClean :: forall (m :: * -> *) a. MonadIO m => RIO PantryApp a -> m a
runPantryAppClean RIO PantryApp a
f =
IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ String -> (String -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"pantry-clean" ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
dir -> RIO SimpleApp a -> IO a
forall (m :: * -> *) a. MonadIO m => RIO SimpleApp a -> m a
runSimpleApp (RIO SimpleApp a -> IO a) -> RIO SimpleApp a -> IO a
forall a b. (a -> b) -> a -> b
$ do
SimpleApp
sa <- RIO SimpleApp SimpleApp
forall r (m :: * -> *). MonadReader r m => m r
ask
Path Abs Dir
root <- String -> RIO SimpleApp (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
dir
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO SimpleApp a)
-> RIO SimpleApp a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> PackageIndexConfig
-> HpackExecutable
-> Force
-> Int
-> Maybe (CasaRepoPrefix, Int)
-> (SnapName -> RawSnapshotLocation)
-> (WantedCompiler -> GlobalHintsLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig'
Path Abs Dir
root
PackageIndexConfig
defaultPackageIndexConfig
HpackExecutable
HpackBundled
Force
Hpack.NoForce
Int
8
((CasaRepoPrefix, Int) -> Maybe (CasaRepoPrefix, Int)
forall a. a -> Maybe a
Just (CasaRepoPrefix
defaultCasaRepoPrefix, Int
defaultCasaMaxPerRequest))
SnapName -> RawSnapshotLocation
defaultSnapshotLocation
WantedCompiler -> GlobalHintsLocation
defaultGlobalHintsLocation
((PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a)
-> (PantryConfig -> RIO SimpleApp a) -> RIO SimpleApp a
forall a b. (a -> b) -> a -> b
$ \PantryConfig
pc ->
PantryApp -> RIO PantryApp a -> RIO SimpleApp a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
PantryApp
{ paSimpleApp :: SimpleApp
paSimpleApp = SimpleApp
sa
, paPantryConfig :: PantryConfig
paPantryConfig = PantryConfig
pc
, paTermWidth :: Int
paTermWidth = Int
100
, paUseColor :: Bool
paUseColor = Bool
True
, paStylesUpdate :: StylesUpdate
paStylesUpdate = StylesUpdate
forall a. Monoid a => a
mempty
}
RIO PantryApp a
f
loadGlobalHints ::
(HasTerm env, HasPantryConfig env)
=> WantedCompiler
-> RIO env (Maybe (Map PackageName Version))
loadGlobalHints :: forall env.
(HasTerm env, HasPantryConfig env) =>
WantedCompiler -> RIO env (Maybe (Map PackageName Version))
loadGlobalHints WantedCompiler
wc = do
Path Abs File
dest <- RIO env (Path Abs File)
forall env. HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile
GlobalHintsLocation
loc <- WantedCompiler -> RIO env GlobalHintsLocation
forall env.
HasPantryConfig env =>
WantedCompiler -> RIO env GlobalHintsLocation
globalHintsLocation WantedCompiler
wc
Path Abs File
-> GlobalHintsLocation
-> Bool
-> RIO env (Maybe (Map PackageName Version))
forall {a} {b} {env}.
(Ord a, IsCabalString a, IsCabalString b, HasTerm env) =>
Path Abs File
-> GlobalHintsLocation -> Bool -> RIO env (Maybe (Map a b))
inner Path Abs File
dest GlobalHintsLocation
loc Bool
False
where
inner :: Path Abs File
-> GlobalHintsLocation -> Bool -> RIO env (Maybe (Map a b))
inner Path Abs File
dest GlobalHintsLocation
loc Bool
alreadyDownloaded = case GlobalHintsLocation
loc of
GHLUrl Text
url -> do
Request
req <- String -> RIO env Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> RIO env Request) -> String -> RIO env Request
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
url
Bool
downloaded <- Request -> Path Abs File -> RIO env Bool
forall env. HasTerm env => Request -> Path Abs File -> RIO env Bool
download Request
req Path Abs File
dest
Maybe (Map a b)
mres <- Path Abs File -> RIO env (Maybe (Map a b))
forall {m :: * -> *} {a} {b} {env} {b} {t}.
(MonadUnliftIO m, Ord a, IsCabalString a, IsCabalString b,
HasTerm env, MonadReader env m) =>
Path b t -> m (Maybe (Map a b))
tryParseYaml Path Abs File
dest
case Maybe (Map a b)
mres of
Maybe (Map a b)
Nothing | Bool -> Bool
not Bool
alreadyDownloaded Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
downloaded -> do
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Could not find local global hints for"
, String -> StyleDoc
string (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Text
forall a. Display a => a -> Text
RIO.textDisplay WantedCompiler
wc) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
, String -> StyleDoc
flow String
"forcing a redownload."
]
Bool
redownloaded <- Request -> Path Abs File -> RIO env Bool
forall env. HasTerm env => Request -> Path Abs File -> RIO env Bool
redownload Request
req Path Abs File
dest
if Bool
redownloaded
then Path Abs File
-> GlobalHintsLocation -> Bool -> RIO env (Maybe (Map a b))
inner Path Abs File
dest GlobalHintsLocation
loc Bool
True
else do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Redownload didn't happen"
Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
forall a. Maybe a
Nothing
Maybe (Map a b)
_ -> Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
mres
GHLFilePath ResolvedPath File
fp -> do
let source :: Path Abs File
source = ResolvedPath File -> Path Abs File
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
fp
Maybe (Map a b)
mres <- Path Abs File -> RIO env (Maybe (Map a b))
forall {m :: * -> *} {a} {b} {env} {b} {t}.
(MonadUnliftIO m, Ord a, IsCabalString a, IsCabalString b,
HasTerm env, MonadReader env m) =>
Path b t -> m (Maybe (Map a b))
tryParseYaml Path Abs File
source
case Maybe (Map a b)
mres of
Maybe (Map a b)
Nothing -> do
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Could not find local global hints for"
, String -> StyleDoc
string (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ WantedCompiler -> Text
forall a. Display a => a -> Text
RIO.textDisplay WantedCompiler
wc)
, StyleDoc
"in"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
source StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
forall a. Maybe a
Nothing
Maybe (Map a b)
_ -> do
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs File -> IO ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
source Path Abs File
dest
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
[ String -> StyleDoc
flow String
"Installed global hints from"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
source
]
Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
mres
inner2 :: Path b t -> m (Maybe (Map a b))
inner2 Path b t
fp = IO (Maybe (Map a b)) -> m (Maybe (Map a b))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Map a b)) -> m (Maybe (Map a b)))
-> IO (Maybe (Map a b)) -> m (Maybe (Map a b))
forall a b. (a -> b) -> a -> b
$ do
Map WantedCompiler (Map (CabalString a) (CabalString b))
allGlobalHints <- String
-> IO (Map WantedCompiler (Map (CabalString a) (CabalString b)))
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow (Path b t -> String
forall b t. Path b t -> String
toFilePath Path b t
fp)
let globalHints :: Maybe (Map (CabalString a) (CabalString b))
globalHints = WantedCompiler
-> Map WantedCompiler (Map (CabalString a) (CabalString b))
-> Maybe (Map (CabalString a) (CabalString b))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WantedCompiler
wc Map WantedCompiler (Map (CabalString a) (CabalString b))
allGlobalHints
Maybe (Map a b) -> IO (Maybe (Map a b))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Map a b) -> IO (Maybe (Map a b)))
-> Maybe (Map a b) -> IO (Maybe (Map a b))
forall a b. (a -> b) -> a -> b
$ (Map (CabalString a) (CabalString b) -> Map a b)
-> Maybe (Map (CabalString a) (CabalString b)) -> Maybe (Map a b)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CabalString b -> b) -> Map a (CabalString b) -> Map a b
forall a b. (a -> b) -> Map a a -> Map a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CabalString b -> b
forall a. CabalString a -> a
unCabalString (Map a (CabalString b) -> Map a b)
-> (Map (CabalString a) (CabalString b) -> Map a (CabalString b))
-> Map (CabalString a) (CabalString b)
-> Map a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (CabalString a) (CabalString b) -> Map a (CabalString b)
forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap) Maybe (Map (CabalString a) (CabalString b))
globalHints
tryParseYaml :: Path b t -> m (Maybe (Map a b))
tryParseYaml Path b t
fp = do
Either SomeException (Maybe (Map a b))
eres <- m (Maybe (Map a b)) -> m (Either SomeException (Maybe (Map a b)))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (Path b t -> m (Maybe (Map a b))
forall {m :: * -> *} {a} {b} {b} {t}.
(MonadIO m, Ord a, IsCabalString a, IsCabalString b) =>
Path b t -> m (Maybe (Map a b))
inner2 Path b t
fp)
case Either SomeException (Maybe (Map a b))
eres of
Left SomeException
e -> do
StyleDoc -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> m ()) -> StyleDoc -> m ()
forall a b. (a -> b) -> a -> b
$
StyleDoc
"[S-912]"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Error when parsing global hints:"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
Maybe (Map a b) -> m (Maybe (Map a b))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
forall a. Maybe a
Nothing
Right Maybe (Map a b)
x -> Maybe (Map a b) -> m (Maybe (Map a b))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
x
partitionReplacedDependencies ::
Ord id
=> Map PackageName a
-> (a -> PackageName)
-> (a -> id)
-> (a -> [id])
-> Set PackageName
-> (Map PackageName [PackageName], Map PackageName a)
partitionReplacedDependencies :: forall id a.
Ord id =>
Map PackageName a
-> (a -> PackageName)
-> (a -> id)
-> (a -> [id])
-> Set PackageName
-> (Map PackageName [PackageName], Map PackageName a)
partitionReplacedDependencies Map PackageName a
globals a -> PackageName
getName a -> id
getId a -> [id]
getDeps Set PackageName
overrides =
(State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a))
-> (Map PackageName [PackageName], Map PackageName a)
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a)
forall s a. State s a -> s -> s
execState (Map PackageName [PackageName]
forall {a}. Map PackageName [a]
replaced, Map PackageName a
forall a. Monoid a => a
mempty) (State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a))
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
-> (Map PackageName [PackageName], Map PackageName a)
forall a b. (a -> b) -> a -> b
$
[(PackageName, a)]
-> ((PackageName, a)
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity Bool)
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Map PackageName a -> [(PackageName, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName a
globals) (((PackageName, a)
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity Bool)
-> State (Map PackageName [PackageName], Map PackageName a) [Bool])
-> ((PackageName, a)
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity Bool)
-> State (Map PackageName [PackageName], Map PackageName a) [Bool]
forall a b. (a -> b) -> a -> b
$ Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity Bool
forall id a.
Ord id =>
Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> State (Map PackageName [PackageName], Map PackageName a) Bool
prunePackageWithDeps Map id a
globals' a -> PackageName
getName a -> [id]
getDeps
where
globals' :: Map id a
globals' = [(id, a)] -> Map id a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(id, a)] -> Map id a) -> [(id, a)] -> Map id a
forall a b. (a -> b) -> a -> b
$ (a -> (id, a)) -> [a] -> [(id, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a -> id
getId (a -> id) -> (a -> a) -> a -> (id, a)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> a
forall a. a -> a
id) (Map PackageName a -> [a]
forall k a. Map k a -> [a]
Map.elems Map PackageName a
globals)
replaced :: Map PackageName [a]
replaced = (a -> [a]) -> Map PackageName a -> Map PackageName [a]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([a] -> a -> [a]
forall a b. a -> b -> a
const []) (Map PackageName a -> Map PackageName [a])
-> Map PackageName a -> Map PackageName [a]
forall a b. (a -> b) -> a -> b
$ Map PackageName a -> Set PackageName -> Map PackageName a
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map PackageName a
globals Set PackageName
overrides
prunePackageWithDeps ::
Ord id
=> Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> State (Map PackageName [PackageName], Map PackageName a) Bool
prunePackageWithDeps :: forall id a.
Ord id =>
Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> State (Map PackageName [PackageName], Map PackageName a) Bool
prunePackageWithDeps Map id a
pkgs a -> PackageName
getName a -> [id]
getDeps (PackageName
pname, a
a) = do
(Map PackageName [PackageName]
pruned, Map PackageName a
kept) <- StateT
(Map PackageName [PackageName], Map PackageName a)
Identity
(Map PackageName [PackageName], Map PackageName a)
forall s (m :: * -> *). MonadState s m => m s
get
if PackageName -> Map PackageName [PackageName] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
pname Map PackageName [PackageName]
pruned
then Bool
-> State (Map PackageName [PackageName], Map PackageName a) Bool
forall a.
a
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else if PackageName -> Map PackageName a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
pname Map PackageName a
kept
then Bool
-> State (Map PackageName [PackageName], Map PackageName a) Bool
forall a.
a
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
else do
let deps :: [a]
deps = Map id a -> [a]
forall k a. Map k a -> [a]
Map.elems (Map id a -> [a]) -> Map id a -> [a]
forall a b. (a -> b) -> a -> b
$ Map id a -> Set id -> Map id a
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map id a
pkgs ([id] -> Set id
forall a. Ord a => [a] -> Set a
Set.fromList ([id] -> Set id) -> [id] -> Set id
forall a b. (a -> b) -> a -> b
$ a -> [id]
getDeps a
a)
[PackageName]
prunedDeps <- [a]
-> (a
-> StateT
(Map PackageName [PackageName], Map PackageName a)
Identity
(Maybe PackageName))
-> StateT
(Map PackageName [PackageName], Map PackageName a)
Identity
[PackageName]
forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM [a]
deps ((a
-> StateT
(Map PackageName [PackageName], Map PackageName a)
Identity
(Maybe PackageName))
-> StateT
(Map PackageName [PackageName], Map PackageName a)
Identity
[PackageName])
-> (a
-> StateT
(Map PackageName [PackageName], Map PackageName a)
Identity
(Maybe PackageName))
-> StateT
(Map PackageName [PackageName], Map PackageName a)
Identity
[PackageName]
forall a b. (a -> b) -> a -> b
$ \a
dep -> do
let depName :: PackageName
depName = a -> PackageName
getName a
dep
Bool
isPruned <- Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> State (Map PackageName [PackageName], Map PackageName a) Bool
forall id a.
Ord id =>
Map id a
-> (a -> PackageName)
-> (a -> [id])
-> (PackageName, a)
-> State (Map PackageName [PackageName], Map PackageName a) Bool
prunePackageWithDeps Map id a
pkgs a -> PackageName
getName a -> [id]
getDeps (PackageName
depName, a
dep)
Maybe PackageName
-> StateT
(Map PackageName [PackageName], Map PackageName a)
Identity
(Maybe PackageName)
forall a.
a
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageName
-> StateT
(Map PackageName [PackageName], Map PackageName a)
Identity
(Maybe PackageName))
-> Maybe PackageName
-> StateT
(Map PackageName [PackageName], Map PackageName a)
Identity
(Maybe PackageName)
forall a b. (a -> b) -> a -> b
$ if Bool
isPruned then PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just PackageName
depName else Maybe PackageName
forall a. Maybe a
Nothing
if [PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
prunedDeps
then do
((Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a))
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a))
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity ())
-> ((Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a))
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity ()
forall a b. (a -> b) -> a -> b
$ (Map PackageName a -> Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (PackageName -> a -> Map PackageName a -> Map PackageName a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageName
pname a
a)
else do
((Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a))
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (((Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a))
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity ())
-> ((Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a))
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity ()
forall a b. (a -> b) -> a -> b
$ (Map PackageName [PackageName] -> Map PackageName [PackageName])
-> (Map PackageName [PackageName], Map PackageName a)
-> (Map PackageName [PackageName], Map PackageName a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (PackageName
-> [PackageName]
-> Map PackageName [PackageName]
-> Map PackageName [PackageName]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageName
pname [PackageName]
prunedDeps)
Bool
-> State (Map PackageName [PackageName], Map PackageName a) Bool
forall a.
a
-> StateT
(Map PackageName [PackageName], Map PackageName a) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
-> State (Map PackageName [PackageName], Map PackageName a) Bool)
-> Bool
-> State (Map PackageName [PackageName], Map PackageName a) Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ([PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
prunedDeps)
withSnapshotCache ::
(HasPantryConfig env, HasLogFunc env)
=> SnapshotCacheHash
-> RIO env (Map PackageName (Set ModuleName))
-> ((ModuleName -> RIO env [PackageName]) -> RIO env a)
-> RIO env a
withSnapshotCache :: forall env a.
(HasPantryConfig env, HasLogFunc env) =>
SnapshotCacheHash
-> RIO env (Map PackageName (Set ModuleName))
-> ((ModuleName -> RIO env [PackageName]) -> RIO env a)
-> RIO env a
withSnapshotCache SnapshotCacheHash
hash RIO env (Map PackageName (Set ModuleName))
getModuleMapping (ModuleName -> RIO env [PackageName]) -> RIO env a
f = do
Maybe SnapshotCacheId
mres <- ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
-> RIO env (Maybe SnapshotCacheId)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
-> RIO env (Maybe SnapshotCacheId))
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
-> RIO env (Maybe SnapshotCacheId)
forall a b. (a -> b) -> a -> b
$ SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
forall env.
SnapshotCacheHash
-> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId)
getSnapshotCacheByHash SnapshotCacheHash
hash
SnapshotCacheId
cacheId <- case Maybe SnapshotCacheId
mres of
Maybe SnapshotCacheId
Nothing -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Populating snapshot module name cache"
Map PackageName (Set ModuleName)
packageModules <- RIO env (Map PackageName (Set ModuleName))
getModuleMapping
ReaderT SqlBackend (RIO env) SnapshotCacheId
-> RIO env SnapshotCacheId
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) SnapshotCacheId
-> RIO env SnapshotCacheId)
-> ReaderT SqlBackend (RIO env) SnapshotCacheId
-> RIO env SnapshotCacheId
forall a b. (a -> b) -> a -> b
$ do
SnapshotCacheId
scId <- SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId
forall env.
SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId
getSnapshotCacheId SnapshotCacheHash
hash
SnapshotCacheId
-> Map PackageName (Set ModuleName)
-> ReaderT SqlBackend (RIO env) ()
forall env.
SnapshotCacheId
-> Map PackageName (Set ModuleName)
-> ReaderT SqlBackend (RIO env) ()
storeSnapshotModuleCache SnapshotCacheId
scId Map PackageName (Set ModuleName)
packageModules
SnapshotCacheId -> ReaderT SqlBackend (RIO env) SnapshotCacheId
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotCacheId
scId
Just SnapshotCacheId
scId -> SnapshotCacheId -> RIO env SnapshotCacheId
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotCacheId
scId
(ModuleName -> RIO env [PackageName]) -> RIO env a
f ((ModuleName -> RIO env [PackageName]) -> RIO env a)
-> (ModuleName -> RIO env [PackageName]) -> RIO env a
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) [PackageName] -> RIO env [PackageName]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) [PackageName]
-> RIO env [PackageName])
-> (ModuleName -> ReaderT SqlBackend (RIO env) [PackageName])
-> ModuleName
-> RIO env [PackageName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotCacheId
-> ModuleName -> ReaderT SqlBackend (RIO env) [PackageName]
forall env.
SnapshotCacheId
-> ModuleName -> ReaderT SqlBackend (RIO env) [PackageName]
loadExposedModulePackages SnapshotCacheId
cacheId
plural :: Int -> Utf8Builder -> Utf8Builder
plural :: Int -> Utf8Builder -> Utf8Builder
plural Int
n Utf8Builder
text =
Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
n
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
text
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
then Utf8Builder
""
else Utf8Builder
"s")