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