{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Pantry
(
PantryConfig
, HackageSecurityConfig (..)
, defaultHackageSecurityConfig
, defaultCasaRepoPrefix
, defaultCasaMaxPerRequest
, defaultSnapshotLocation
, HasPantryConfig (..)
, withPantryConfig
, HpackExecutable (..)
, PantryApp
, runPantryApp
, runPantryAppClean
, runPantryAppWith
, hpackExecutableL
, PantryException (..)
, PackageName
, Version
, FlagName
, PackageIdentifier (..)
, FileSize (..)
, RelFilePath (..)
, ResolvedPath (..)
, Unresolved
, SHA256
, TreeKey (..)
, BlobKey (..)
, RawPackageMetadata (..)
, PackageMetadata (..)
, Package (..)
, CabalFileInfo (..)
, Revision (..)
, PackageIdentifierRevision (..)
, UsePreferredVersions (..)
, RawArchive (..)
, Archive (..)
, ArchiveLocation (..)
, Repo (..)
, RepoType (..)
, withRepo
, RawPackageLocation (..)
, PackageLocation (..)
, toRawPL
, RawPackageLocationImmutable (..)
, PackageLocationImmutable (..)
, RawSnapshotLocation (..)
, SnapshotLocation (..)
, toRawSL
, RawSnapshot (..)
, Snapshot (..)
, RawSnapshotPackage (..)
, SnapshotPackage (..)
, RawSnapshotLayer (..)
, SnapshotLayer (..)
, toRawSnapshotLayer
, WantedCompiler (..)
, SnapName (..)
, snapshotLocation
, resolvePaths
, loadPackageRaw
, tryLoadPackageRawViaCasa
, loadPackage
, loadRawSnapshotLayer
, loadSnapshotLayer
, loadSnapshot
, loadAndCompleteSnapshot
, 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 Database.Persist (entityKey)
import RIO
import Conduit
import Control.Arrow (right)
import Control.Monad.State.Strict (State, execState, get, modify')
import qualified RIO.Map as Map
import qualified RIO.Set as Set
import qualified RIO.ByteString as B
import qualified RIO.Text as T
import qualified RIO.List as List
import qualified RIO.FilePath as FilePath
import Pantry.Archive
import Pantry.Casa
import Casa.Client (thParserCasaRepo, CasaRepoPrefix)
import Pantry.Repo
import qualified Pantry.SHA256 as SHA256
import Pantry.Storage hiding (TreeEntry, PackageName, Version)
import Pantry.Tree
import Pantry.Types as P
import Pantry.Hackage
import Path (Path, Abs, File, toFilePath, Dir, (</>), filename, parseAbsDir, parent, parseRelFile)
import Path.IO (doesFileExist, resolveDir', listDir)
import Distribution.PackageDescription (GenericPackageDescription, FlagName)
import qualified Distribution.PackageDescription as D
import Distribution.Parsec (PWarning (..), showPos)
import qualified Hpack
import qualified Hpack.Config as Hpack
import Network.HTTP.Download
import RIO.PrettyPrint
import RIO.PrettyPrint.StylesUpdate
import RIO.Process
import RIO.Directory (getAppUserDataDirectory)
import qualified Data.Yaml as Yaml
import Pantry.Internal.AesonExtended (WithJSONWarnings (..), Value)
import Data.Aeson.Types (parseEither)
import Data.Monoid (Endo (..))
import Pantry.HTTP
import Data.Char (isHexDigit)
import Data.Time (getCurrentTime, diffUTCTime)
withPantryConfig
:: HasLogFunc env
=> Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig :: Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig Path Abs Dir
root HackageSecurityConfig
hsc HpackExecutable
he Int
count CasaRepoPrefix
pullURL Int
maxPerRequest SnapName -> RawSnapshotLocation
snapLoc PantryConfig -> RIO env a
inner = do
env
env <- RIO env env
forall r (m :: * -> *). MonadReader r m => m r
ask
Path Rel File
pantryRelFile <- FilePath -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
"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 :: HackageSecurityConfig
-> HpackExecutable
-> Path Abs Dir
-> Storage
-> MVar Bool
-> IORef
(Map RawPackageLocationImmutable GenericPackageDescription)
-> IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File))
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> PantryConfig
PantryConfig
{ pcHackageSecurity :: HackageSecurityConfig
pcHackageSecurity = HackageSecurityConfig
hsc
, pcHpackExecutable :: HpackExecutable
pcHpackExecutable = HpackExecutable
he
, 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
, pcCasaRepoPrefix :: CasaRepoPrefix
pcCasaRepoPrefix = CasaRepoPrefix
pullURL
, pcCasaMaxPerRequest :: Int
pcCasaMaxPerRequest = Int
maxPerRequest
, pcSnapshotLocation :: SnapName -> RawSnapshotLocation
pcSnapshotLocation = SnapName -> RawSnapshotLocation
snapLoc
}
defaultCasaRepoPrefix :: CasaRepoPrefix
defaultCasaRepoPrefix :: CasaRepoPrefix
defaultCasaRepoPrefix = $(thParserCasaRepo "https://casa.fpcomplete.com")
defaultCasaMaxPerRequest :: Int
defaultCasaMaxPerRequest :: Int
defaultCasaMaxPerRequest = Int
1280
defaultHackageSecurityConfig :: HackageSecurityConfig
defaultHackageSecurityConfig :: HackageSecurityConfig
defaultHackageSecurityConfig = HackageSecurityConfig :: [Text] -> Int -> Text -> Bool -> HackageSecurityConfig
HackageSecurityConfig
{ hscKeyIds :: [Text]
hscKeyIds =
[ Text
"0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
, Text
"1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
, Text
"280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833"
, Text
"2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201"
, Text
"2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3"
, Text
"51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
, Text
"772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d"
, Text
"aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9"
, Text
"fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
]
, hscKeyThreshold :: Int
hscKeyThreshold = Int
3
, hscDownloadPrefix :: Text
hscDownloadPrefix = Text
"https://hackage.haskell.org/"
, hscIgnoreExpiry :: Bool
hscIgnoreExpiry = Bool
False
}
getLatestHackageVersion
:: (HasPantryConfig env, HasLogFunc env)
=> RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageIdentifierRevision)
getLatestHackageVersion :: 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 (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 (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 :: 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 (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 (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 (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 :: 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))
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
-> Maybe (Revision, BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Revision, BlobKey), Map Revision BlobKey) -> (Revision, BlobKey)
forall a b. (a, b) -> a
fst (Maybe ((Revision, BlobKey), Map Revision BlobKey)
-> Maybe (Revision, BlobKey))
-> Maybe ((Revision, BlobKey), Map Revision BlobKey)
-> Maybe (Revision, BlobKey)
forall a b. (a -> b) -> a -> 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (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 :: [RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys [RawPackageLocationImmutable]
treeKeys = do
() -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[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 (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 (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 (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 (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 (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)))
()
-> ConduitM
(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 =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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)))
()
-> ConduitM
(TreeKey, Tree)
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
[(TreeKey, Tree)]
-> ConduitM
(BlobKey, ByteString)
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
[(TreeKey, Tree)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.|
ConduitM
(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 (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 (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 (t :: * -> *) a. Foldable t => t a -> [a]
toList Map SafeFilePath TreeEntry
files)))
Map TreeKey Tree
treeKeyBlobs
UTCTime
pullBlobStart <- IO UTCTime -> RIO env UTCTime
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 (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 (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)))
()
-> ConduitM
(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 =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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)))
()
-> ConduitM Int Void (ResourceT (ReaderT SqlBackend (RIO env))) Int
-> ConduitM
(BlobKey, ByteString)
Void
(ResourceT (ReaderT SqlBackend (RIO env)))
Int
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM 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 (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 (FilePath -> Text
T.pack (NominalDiffTime -> FilePath
forall a. Show a => a -> FilePath
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 (FilePath -> Text
T.pack (NominalDiffTime -> FilePath
forall a. Show a => a -> FilePath
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 (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 :: 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (f PackageLocationImmutable -> [PackageLocationImmutable]
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 (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 :: 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 (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 :: 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 (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 :: 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 :: PackageIdentifier -> TreeKey -> PackageMetadata
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 (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 (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
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 (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 :: 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 :: Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
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 (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 (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
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 (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)
=> RawPackageLocation
-> RIO env GenericPackageDescription
loadCabalFileRaw :: RawPackageLocation -> RIO env GenericPackageDescription
loadCabalFileRaw (RPLImmutable RawPackageLocationImmutable
loc) = RawPackageLocationImmutable -> RIO env GenericPackageDescription
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileRawImmutable RawPackageLocationImmutable
loc
loadCabalFileRaw (RPLMutable ResolvedPath Dir
rfp) = do
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
_) <- Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
IO GenericPackageDescription -> RIO env GenericPackageDescription
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)
=> PackageLocation
-> RIO env GenericPackageDescription
loadCabalFile :: PackageLocation -> RIO env GenericPackageDescription
loadCabalFile (PLImmutable PackageLocationImmutable
loc) = PackageLocationImmutable -> RIO env GenericPackageDescription
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
loc
loadCabalFile (PLMutable ResolvedPath Dir
rfp) = do
(PrintWarnings -> IO GenericPackageDescription
gpdio, PackageName
_, Path Abs File
_) <- Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath (ResolvedPath Dir -> Path Abs Dir
forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
rfp)
IO GenericPackageDescription -> RIO env GenericPackageDescription
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)
=> Path Abs Dir
-> RIO env
( PrintWarnings -> IO GenericPackageDescription
, PackageName
, Path Abs File
)
loadCabalFilePath :: Path Abs Dir
-> RIO
env
(PrintWarnings -> IO GenericPackageDescription, PackageName,
Path Abs File)
loadCabalFilePath 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
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 (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) <- Path Abs Dir -> RIO env (PackageName, Path Abs File)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile 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 (f :: * -> *) a. Applicative f => a -> f a
pure ([PWarning], GenericPackageDescription)
pair
Maybe ([PWarning], GenericPackageDescription)
Nothing -> do
ByteString
bs <- IO ByteString -> m ByteString
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
$ FilePath -> IO ByteString
forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
B.readFile (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
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 (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 (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 (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 FilePath
msg) =
Utf8Builder
"Cabal file warning in" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
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
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Position -> FilePath
showPos Position
pos) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
msg
checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m ()
checkCabalFileName :: PackageName -> Path Abs File -> m ()
checkCabalFileName PackageName
name Path Abs File
cabalfp = do
let expected :: FilePath
expected = Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
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 (FilePath
expected FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= Path Rel File -> FilePath
forall b t. Path b t -> FilePath
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 (m :: * -> *) e a. (MonadThrow m, 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)
=> Path Abs Dir
-> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile :: Path Abs Dir -> RIO env (PackageName, Path Abs File)
findOrGenerateCabalFile Path Abs Dir
pkgDir = do
Path Abs Dir -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> RIO env ()
hpack Path Abs Dir
pkgDir
[Path Abs File]
files <- (Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool) -> FilePath -> FilePath -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> FilePath -> Bool
hasExtension FilePath
"cabal" (FilePath -> Bool)
-> (Path Abs File -> FilePath) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath) ([Path Abs File] -> [Path Abs File])
-> (([Path Abs Dir], [Path Abs File]) -> [Path Abs File])
-> ([Path Abs Dir], [Path Abs File])
-> [Path Abs File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Path Abs Dir], [Path Abs File]) -> [Path Abs File]
forall a b. (a, b) -> b
snd
(([Path Abs Dir], [Path Abs File]) -> [Path Abs File])
-> RIO env ([Path Abs Dir], [Path Abs File])
-> RIO env [Path Abs File]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
let isHidden :: FilePath -> Bool
isHidden (Char
'.':FilePath
_) = Bool
True
isHidden FilePath
_ = 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
. FilePath -> Bool
isHidden (FilePath -> Bool)
-> (Path Abs File -> FilePath) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Rel File -> FilePath)
-> (Path Abs File -> Path Rel File) -> Path Abs File -> FilePath
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 (f :: * -> *) a. Applicative f => a -> f a
pure ((PackageName, Path Abs File)
-> RIO env (PackageName, Path Abs File))
-> (PackageName, Path Abs File)
-> RIO env (PackageName, Path Abs File)
forall a b. (a -> b) -> a -> b
$ (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
$
FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripSuffix FilePath
".cabal" (Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
x)) Maybe FilePath
-> (FilePath -> Maybe PackageName) -> Maybe PackageName
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
FilePath -> 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 :: FilePath -> FilePath -> Bool
hasExtension FilePath
fp FilePath
x = FilePath -> FilePath
FilePath.takeExtension FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x
hpack
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> Path Abs Dir
-> RIO env ()
hpack :: Path Abs Dir -> RIO env ()
hpack Path Abs Dir
pkgDir = do
Path Rel File
packageConfigRelFile <- FilePath -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
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
Bool
exists <- IO Bool -> RIO env Bool
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
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
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
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
case HpackExecutable
he of
HpackExecutable
HpackBundled -> do
Result
r <- IO Result -> RIO env Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> RIO env Result) -> IO Result -> RIO env Result
forall a b. (a -> b) -> a -> b
$ Options -> IO Result
Hpack.hpackResult (Options -> IO Result) -> Options -> IO Result
forall a b. (a -> b) -> a -> b
$ ProgramName -> Options -> Options
Hpack.setProgramName ProgramName
"stack" (Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ FilePath -> Options -> Options
Hpack.setTarget (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
hpackFile) Options
Hpack.defaultOptions
[FilePath] -> (FilePath -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Result -> [FilePath]
Hpack.resultWarnings Result
r) (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> (FilePath -> Utf8Builder) -> FilePath -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString)
let cabalFile :: Utf8Builder
cabalFile = FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (FilePath -> Utf8Builder)
-> (Result -> FilePath) -> Result -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> FilePath
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,\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"please upgrade and try again."
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
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
hpackFile) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" in favor of the cabal file.\nIf you want to use the " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Path Rel File -> FilePath
forall b t. Path b t -> FilePath
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 FilePath
command ->
FilePath -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
FilePath -> m a -> m a
withWorkingDir (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
pkgDir) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env ())
-> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
command [] ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
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 :: 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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
loadRawCabalFileBytes
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> RIO env ByteString
loadRawCabalFileBytes :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
loadPackage
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> PackageLocationImmutable
-> RIO env Package
loadPackage :: 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 :: 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'
case Maybe Package
mpackage of
Maybe Package
Nothing -> RIO env Package
loadPackageRawViaThirdParty
Just Package
package -> Package -> RIO env Package
forall (f :: * -> *) a. Applicative f => a -> f a
pure Package
package
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 :: RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaDbOrCasa RawPackageLocationImmutable
rpli TreeKey
treeKey' = do
Maybe Package
mviaDb <- 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'
case Maybe Package
mviaDb of
Just Package
package -> do
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)
Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Maybe Package
forall a. a -> Maybe a
Just Package
package)
Maybe Package
Nothing -> do
Maybe Package
mviaCasa <- 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'
case Maybe Package
mviaCasa of
Just Package
package -> do
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)
Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Maybe Package
forall a. a -> Maybe a
Just Package
package)
Maybe Package
Nothing -> Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
tryLoadPackageRawViaCasa ::
(HasLogFunc env, HasPantryConfig env, HasProcessContext env)
=> RawPackageLocationImmutable
-> TreeKey
-> RIO env (Maybe Package)
tryLoadPackageRawViaCasa :: RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaCasa RawPackageLocationImmutable
rlpi TreeKey
treeKey' = do
Maybe (TreeKey, Tree)
mtreePair <- TreeKey -> RIO env (Maybe (TreeKey, Tree))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
TreeKey -> RIO env (Maybe (TreeKey, Tree))
casaLookupTree TreeKey
treeKey'
case Maybe (TreeKey, Tree)
mtreePair of
Maybe (TreeKey, Tree)
Nothing -> Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
Just (TreeKey
treeKey'', Tree
_tree) -> do
[RawPackageLocationImmutable] -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
[RawPackageLocationImmutable] -> RIO env ()
fetchTreeKeys [RawPackageLocationImmutable
rlpi]
Maybe Package
mdb <- RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rlpi TreeKey
treeKey''
case Maybe Package
mdb of
Maybe Package
Nothing -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
(Utf8Builder
"Did not find tree key in DB after pulling it from Casa: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
TreeKey -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display TreeKey
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
")")
Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
Just Package
package -> Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Package -> Maybe Package
forall a. a -> Maybe a
Just Package
package)
tryLoadPackageRawViaLocalDb ::
(HasLogFunc env, HasPantryConfig env, HasProcessContext env)
=> RawPackageLocationImmutable
-> TreeKey
-> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb :: RawPackageLocationImmutable -> TreeKey -> RIO env (Maybe Package)
tryLoadPackageRawViaLocalDb RawPackageLocationImmutable
rlpi TreeKey
treeKey' = do
Maybe (Entity Tree)
mtreeEntity <- 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')
case Maybe (Entity Tree)
mtreeEntity of
Maybe (Entity Tree)
Nothing -> Maybe Package -> RIO env (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing
Just Entity Tree
treeId ->
(Package -> Maybe Package)
-> RIO env Package -> RIO env (Maybe Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Package -> Maybe Package
forall a. a -> Maybe a
Just (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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
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
$ FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (FilePath -> Utf8Builder) -> FilePath -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ (RawPackageLocationImmutable, SHA256, FileSize, Package)
-> FilePath
forall a. Show a => a -> FilePath
show (RawPackageLocationImmutable
pl, SHA256
sha, FileSize
size, Package
package)
CompletePackageLocation -> RIO env CompletePackageLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
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 (f :: * -> *) a. Applicative f => a -> f a
pure CompletePackageLocation :: PackageLocationImmutable -> Bool -> CompletePackageLocation
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 :: PackageIdentifier -> TreeKey -> PackageMetadata
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 :: RawSnapshotLocation -> RIO env SnapshotLocation
completeSnapshotLocation (RSLCompiler WantedCompiler
c) = SnapshotLocation -> RIO env SnapshotLocation
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 (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 (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 (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_ :: (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
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_ :: 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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure (() -> m ()
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 (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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot :: WantedCompiler
-> Map PackageName RawSnapshotPackage
-> Set PackageName
-> RawSnapshot
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 :: Set PackageName
-> Map PackageName (Map FlagName Bool)
-> Map PackageName Bool
-> Map PackageName [Text]
-> AddPackagesConfig
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 (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot :: WantedCompiler
-> Map PackageName RawSnapshotPackage
-> Set PackageName
-> RawSnapshot
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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot :: WantedCompiler
-> Map PackageName RawSnapshotPackage
-> Set PackageName
-> RawSnapshot
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 :: Set PackageName
-> Map PackageName (Map FlagName Bool)
-> Map PackageName Bool
-> Map PackageName [Text]
-> AddPackagesConfig
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 (f :: * -> *) a. Applicative f => a -> f a
pure RawSnapshot :: WantedCompiler
-> Map PackageName RawSnapshotPackage
-> Set PackageName
-> RawSnapshot
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 :: SnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshot SnapshotLocation
loc Map RawSnapshotLocation SnapshotLocation
cachedSL Map RawPackageLocationImmutable PackageLocationImmutable
cachedPL =
RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
loc) Map RawSnapshotLocation SnapshotLocation
cachedSL Map RawPackageLocationImmutable PackageLocationImmutable
cachedPL
loadAndCompleteSnapshotRaw
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw :: RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw 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 (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right (\RawSnapshotLayer
rsl -> (RawSnapshotLayer
rsl, (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 :: WantedCompiler
-> Map PackageName SnapshotPackage -> Set PackageName -> 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 (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) <- RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw (RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsl) Map RawSnapshotLocation SnapshotLocation
cacheSL Map RawPackageLocationImmutable PackageLocationImmutable
cachePL
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
$ FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (FilePath -> Utf8Builder) -> FilePath -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ RawSnapshotLayer -> FilePath
forall a. Show a => a -> FilePath
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 :: Set PackageName
-> Map PackageName (Map FlagName Bool)
-> Map PackageName Bool
-> Map PackageName [Text]
-> AddPackagesConfig
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 :: WantedCompiler
-> Map PackageName SnapshotPackage -> Set PackageName -> 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 (m :: * -> *) a. Monad m => a -> m a
return (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 :: (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 :: 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 (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 non-existent package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
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 non-existent package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
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 non-existent package: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure (PackageName
name, RawSnapshotPackage :: RawPackageLocationImmutable
-> Map FlagName Bool -> Bool -> [Text] -> RawSnapshotPackage
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 (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 (t :: * -> *) a. Foldable t => t a -> Bool
null ([(PackageName, [RawSnapshotPackage])] -> Bool)
-> [(PackageName, [RawSnapshotPackage])] -> Bool
forall a b. (a -> b) -> a -> b
$ [(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 (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 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 (RawSnapshotPackage -> Map FlagName Bool
rspFlags RawSnapshotPackage
rsp) 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 (RawSnapshotPackage -> Bool
rspHidden RawSnapshotPackage
rsp) 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 (RawSnapshotPackage -> [Text]
rspGhcOptions RawSnapshotPackage
rsp) PackageName
name Map PackageName [Text]
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 (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 :: Map RawPackageLocationImmutable PackageLocationImmutable
-> RawPackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
cachedSnapshotCompletePackageLocation Map RawPackageLocationImmutable PackageLocationImmutable
cachePackages RawPackageLocationImmutable
rpli = do
let xs :: Maybe PackageLocationImmutable
xs = 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
case Maybe PackageLocationImmutable
xs of
Maybe PackageLocationImmutable
Nothing -> do
CompletePackageLocation
cpl <- RawPackageLocationImmutable -> RIO env CompletePackageLocation
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable -> RIO env CompletePackageLocation
completePackageLocation RawPackageLocationImmutable
rpli
Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable))
-> Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ if CompletePackageLocation -> Bool
cplHasCabalFile CompletePackageLocation
cpl then PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just (CompletePackageLocation -> PackageLocationImmutable
cplComplete CompletePackageLocation
cpl) else Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
Just PackageLocationImmutable
x -> Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable))
-> Maybe PackageLocationImmutable
-> RIO env (Maybe PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just PackageLocationImmutable
x
addAndCompletePackagesToSnapshot
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawSnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> [RawPackageLocationImmutable]
-> AddPackagesConfig
-> Map PackageName SnapshotPackage
-> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig)
addAndCompletePackagesToSnapshot :: 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 :: ([(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 (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 :: PackageLocationImmutable
-> Map FlagName Bool -> Bool -> [Text] -> SnapshotPackage
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 (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 (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 (t :: * -> *) a. Foldable t => t a -> Bool
null ([(PackageName, [SnapshotPackage])] -> Bool)
-> [(PackageName, [SnapshotPackage])] -> Bool
forall a b. (a -> b) -> a -> b
$ [(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 (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 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 (SnapshotPackage -> Map FlagName Bool
spFlags SnapshotPackage
sp) 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 (SnapshotPackage -> Bool
spHidden SnapshotPackage
sp) 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 (SnapshotPackage -> [Text]
spGhcOptions SnapshotPackage
sp) PackageName
name Map PackageName [Text]
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 (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 :: RawSnapshotLocation
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
loadRawSnapshotLayer (RSLCompiler WantedCompiler
compiler) = Either WantedCompiler (RawSnapshotLayer, CompletedSL)
-> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL))
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 (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 <- FilePath -> RIO env Value
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => FilePath -> m a
Yaml.decodeFileThrow (FilePath -> RIO env Value) -> FilePath -> RIO env Value
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> FilePath) -> Path Abs File -> FilePath
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 (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 (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 :: SnapshotLocation
-> RIO env (Either WantedCompiler RawSnapshotLayer)
loadSnapshotLayer (SLCompiler WantedCompiler
compiler) = Either WantedCompiler RawSnapshotLayer
-> RIO env (Either WantedCompiler RawSnapshotLayer)
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 (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 <- FilePath -> RIO env Value
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => FilePath -> m a
Yaml.decodeFileThrow (FilePath -> RIO env Value) -> FilePath -> RIO env Value
forall a b. (a -> b) -> a -> b
$ Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs File -> FilePath) -> Path Abs File -> FilePath
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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 :: 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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
warningsParserHelperRaw
:: HasLogFunc env
=> RawSnapshotLocation
-> Value
-> Maybe (Path Abs Dir)
-> RIO env RawSnapshotLayer
warningsParserHelperRaw :: 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 FilePath (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a b. (a -> Parser b) -> a -> Either FilePath b
parseEither Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a. FromJSON a => Value -> Parser a
Yaml.parseJSON Value
val of
Left FilePath
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 -> FilePath -> PantryException
Couldn'tParseSnapshot RawSnapshotLocation
rsl FilePath
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 (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 :: 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 FilePath (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a b. (a -> Parser b) -> a -> Either FilePath b
parseEither Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer))
forall a. FromJSON a => Value -> Parser a
Yaml.parseJSON Value
val of
Left FilePath
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 -> FilePath -> PantryException
Couldn'tParseSnapshot (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl) FilePath
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 (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 :: RawPackageLocationImmutable -> RIO env PackageName
getPackageLocationName = (PackageIdentifier -> PackageName)
-> RIO env PackageIdentifier -> RIO env PackageName
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 :: RawPackageLocationImmutable -> RIO env PackageIdentifier
getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
_) Maybe TreeKey
_) = PackageIdentifier -> RIO env PackageIdentifier
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 (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 (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 :: RawPackageLocationImmutable -> RIO env TreeKey
getRawPackageLocationTreeKey RawPackageLocationImmutable
pl =
case RawPackageLocationImmutable -> Maybe TreeKey
getRawTreeKey RawPackageLocationImmutable
pl of
Just TreeKey
treeKey' -> TreeKey -> RIO env TreeKey
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 :: PackageLocationImmutable -> RIO env TreeKey
getPackageLocationTreeKey PackageLocationImmutable
pl = TreeKey -> RIO env TreeKey
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 :: (SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp
simpleAppL = (PantryApp -> SimpleApp)
-> (PantryApp -> SimpleApp -> PantryApp)
-> Lens PantryApp PantryApp SimpleApp 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 :: SimpleApp
paSimpleApp = SimpleApp
y })
hpackExecutableL :: Lens' PantryConfig HpackExecutable
hpackExecutableL :: (HpackExecutable -> f HpackExecutable)
-> PantryConfig -> f PantryConfig
hpackExecutableL HpackExecutable -> f HpackExecutable
k PantryConfig
pconfig = (HpackExecutable -> PantryConfig)
-> f HpackExecutable -> f PantryConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HpackExecutable
hpExe -> PantryConfig
pconfig { pcHpackExecutable :: HpackExecutable
pcHpackExecutable = HpackExecutable
hpExe }) (HpackExecutable -> f HpackExecutable
k (PantryConfig -> HpackExecutable
pcHpackExecutable PantryConfig
pconfig))
instance HasLogFunc PantryApp where
logFuncL :: (LogFunc -> f LogFunc) -> PantryApp -> f PantryApp
logFuncL = (SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp
Lens PantryApp PantryApp SimpleApp 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
logFuncL
instance HasPantryConfig PantryApp where
pantryConfigL :: (PantryConfig -> f PantryConfig) -> PantryApp -> f PantryApp
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 :: PantryConfig
paPantryConfig = PantryConfig
y })
instance HasProcessContext PantryApp where
processContextL :: (ProcessContext -> f ProcessContext) -> PantryApp -> f PantryApp
processContextL = (SimpleApp -> f SimpleApp) -> PantryApp -> f PantryApp
Lens PantryApp PantryApp SimpleApp 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
processContextL
instance HasStylesUpdate PantryApp where
stylesUpdateL :: (StylesUpdate -> f StylesUpdate) -> PantryApp -> f PantryApp
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 :: StylesUpdate
paStylesUpdate = StylesUpdate
y })
instance HasTerm PantryApp where
useColorL :: (Bool -> f Bool) -> PantryApp -> f PantryApp
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 :: Bool
paUseColor = Bool
y })
termWidthL :: (Int -> f Int) -> PantryApp -> f PantryApp
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 :: Int
paTermWidth = Int
y })
runPantryApp :: MonadIO m => RIO PantryApp a -> m a
runPantryApp :: 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 :: 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
FilePath
stack <- FilePath -> RIO SimpleApp FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
getAppUserDataDirectory FilePath
"stack"
Path Abs Dir
root <- FilePath -> RIO SimpleApp (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs Dir)
parseAbsDir (FilePath -> RIO SimpleApp (Path Abs Dir))
-> FilePath -> RIO SimpleApp (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ FilePath
stack FilePath -> FilePath -> FilePath
FilePath.</> FilePath
"pantry"
Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO SimpleApp a)
-> RIO SimpleApp a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig
Path Abs Dir
root
HackageSecurityConfig
defaultHackageSecurityConfig
HpackExecutable
HpackBundled
Int
maxConnCount
CasaRepoPrefix
casaRepoPrefix
Int
casaMaxPerRequest
SnapName -> RawSnapshotLocation
defaultSnapshotLocation
((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 :: SimpleApp
-> PantryConfig -> Bool -> Int -> StylesUpdate -> PantryApp
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 :: RIO PantryApp a -> m a
runPantryAppClean RIO PantryApp a
f = 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
$ FilePath -> (FilePath -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"pantry-clean" ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
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 <- FilePath -> RIO SimpleApp (Path Abs Dir)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs Dir)
resolveDir' FilePath
dir
Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO SimpleApp a)
-> RIO SimpleApp a
forall env a.
HasLogFunc env =>
Path Abs Dir
-> HackageSecurityConfig
-> HpackExecutable
-> Int
-> CasaRepoPrefix
-> Int
-> (SnapName -> RawSnapshotLocation)
-> (PantryConfig -> RIO env a)
-> RIO env a
withPantryConfig
Path Abs Dir
root
HackageSecurityConfig
defaultHackageSecurityConfig
HpackExecutable
HpackBundled
Int
8
CasaRepoPrefix
defaultCasaRepoPrefix
Int
defaultCasaMaxPerRequest
SnapName -> RawSnapshotLocation
defaultSnapshotLocation
((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 :: SimpleApp
-> PantryConfig -> Bool -> Int -> StylesUpdate -> PantryApp
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 :: WantedCompiler -> RIO env (Maybe (Map PackageName Version))
loadGlobalHints WantedCompiler
wc =
Bool -> RIO env (Maybe (Map PackageName Version))
forall b a env.
(IsCabalString b, IsCabalString a, Ord a, HasPantryConfig env,
HasTerm env) =>
Bool -> RIO env (Maybe (Map a b))
inner Bool
False
where
inner :: Bool -> RIO env (Maybe (Map a b))
inner Bool
alreadyDownloaded = do
Path Abs File
dest <- RIO env (Path Abs File)
forall env. HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile
Request
req <- FilePath -> RIO env Request
forall (m :: * -> *). MonadThrow m => FilePath -> m Request
parseRequest FilePath
"https://raw.githubusercontent.com/fpco/stackage-content/master/stack/global-hints.yaml"
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
Either SomeException (Maybe (Map a b))
eres <- RIO env (Maybe (Map a b))
-> RIO env (Either SomeException (Maybe (Map a b)))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (Path Abs File -> RIO env (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 Abs File
dest)
Maybe (Map a b)
mres <-
case Either SomeException (Maybe (Map a b))
eres of
Left SomeException
e -> Maybe (Map a b)
forall a. Maybe a
Nothing Maybe (Map a b) -> RIO env () -> RIO env (Maybe (Map a b))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder
"Error when parsing global hints: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SomeException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SomeException
e)
Right Maybe (Map a b)
x -> Maybe (Map a b) -> RIO env (Maybe (Map a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map a b)
x
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
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Could not find local global hints for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
WantedCompiler -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display WantedCompiler
wc Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
", forcing a redownload"
Bool
x <- 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
x
then Bool -> RIO env (Maybe (Map a b))
inner 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 (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 (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
dest
= IO (Maybe (Map a b)) -> m (Maybe (Map a b))
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
$ WantedCompiler -> Map WantedCompiler (Map a b) -> Maybe (Map a b)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup WantedCompiler
wc (Map WantedCompiler (Map a b) -> Maybe (Map a b))
-> (Map WantedCompiler (Map (CabalString a) (CabalString b))
-> Map WantedCompiler (Map a b))
-> Map WantedCompiler (Map (CabalString a) (CabalString b))
-> Maybe (Map a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (CabalString a) (CabalString b) -> Map a b)
-> Map WantedCompiler (Map (CabalString a) (CabalString b))
-> Map WantedCompiler (Map a 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 (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)
(Map WantedCompiler (Map (CabalString a) (CabalString b))
-> Maybe (Map a b))
-> IO (Map WantedCompiler (Map (CabalString a) (CabalString b)))
-> IO (Maybe (Map a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> IO (Map WantedCompiler (Map (CabalString a) (CabalString b)))
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => FilePath -> m a
Yaml.decodeFileThrow (Path b t -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b t
dest)
partitionReplacedDependencies ::
Ord id
=> Map PackageName a
-> (a -> PackageName)
-> (a -> id)
-> (a -> [id])
-> Set PackageName
-> (Map PackageName [PackageName], Map PackageName a)
partitionReplacedDependencies :: 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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return (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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return SnapshotCacheId
scId
Just SnapshotCacheId
scId -> SnapshotCacheId -> RIO env SnapshotCacheId
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")