{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Build.Installed
( InstalledMap
, Installed (..)
, getInstalled
, InstallMap
, toInstallMap
) where
import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Path
import Stack.Build.Cache
import Stack.Constants
import Stack.PackageDump
import Stack.Prelude
import Stack.SourceMap (getPLIVersion, loadVersion)
import Stack.Types.Build
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.Package
import Stack.Types.SourceMap
toInstallMap :: MonadIO m => SourceMap -> m InstallMap
toInstallMap :: forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap = do
InstallMap
projectInstalls <-
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap) forall a b. (a -> b) -> a -> b
$ \ProjectPackage
pp -> do
Version
version <- forall (m :: * -> *). MonadIO m => CommonPackage -> m Version
loadVersion (ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Local, Version
version)
InstallMap
depInstalls <-
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap) forall a b. (a -> b) -> a -> b
$ \DepPackage
dp ->
case DepPackage -> PackageLocation
dpLocation DepPackage
dp of
PLImmutable PackageLocationImmutable
pli -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Snap, PackageLocationImmutable -> Version
getPLIVersion PackageLocationImmutable
pli)
PLMutable ResolvedPath Dir
_ -> do
Version
version <- forall (m :: * -> *). MonadIO m => CommonPackage -> m Version
loadVersion (DepPackage -> CommonPackage
dpCommon DepPackage
dp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Local, Version
version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ InstallMap
projectInstalls forall a. Semigroup a => a -> a -> a
<> InstallMap
depInstalls
getInstalled :: HasEnvConfig env
=> InstallMap
-> RIO env
( InstalledMap
, [DumpPackage]
, [DumpPackage]
, [DumpPackage]
)
getInstalled :: forall env.
HasEnvConfig env =>
InstallMap
-> RIO
env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Finding out which packages are already installed"
Path Abs Dir
snapDBPath <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseDeps
Path Abs Dir
localDBPath <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
[Path Abs Dir]
extraDBPaths <- forall env (m :: * -> *).
(MonadReader env m, HasEnvConfig env) =>
m [Path Abs Dir]
packageDatabaseExtra
let loadDatabase' :: Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' = forall env.
HasEnvConfig env =>
InstallMap
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase InstallMap
installMap
([LoadHelper]
installedLibs0, [DumpPackage]
globalDumpPkgs) <- Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' forall a. Maybe a
Nothing []
([LoadHelper]
installedLibs1, [DumpPackage]
_extraInstalled) <-
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\([LoadHelper], [DumpPackage])
lhs' Path Abs Dir
pkgdb ->
Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' (forall a. a -> Maybe a
Just (InstalledPackageLocation
ExtraGlobal, Path Abs Dir
pkgdb)) (forall a b. (a, b) -> a
fst ([LoadHelper], [DumpPackage])
lhs')
) ([LoadHelper]
installedLibs0, [DumpPackage]
globalDumpPkgs) [Path Abs Dir]
extraDBPaths
([LoadHelper]
installedLibs2, [DumpPackage]
snapshotDumpPkgs) <-
Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' (forall a. a -> Maybe a
Just (InstallLocation -> InstalledPackageLocation
InstalledTo InstallLocation
Snap, Path Abs Dir
snapDBPath)) [LoadHelper]
installedLibs1
([LoadHelper]
installedLibs3, [DumpPackage]
localDumpPkgs) <-
Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' (forall a. a -> Maybe a
Just (InstallLocation -> InstalledPackageLocation
InstalledTo InstallLocation
Local, Path Abs Dir
localDBPath)) [LoadHelper]
installedLibs2
let installedLibs :: InstalledMap
installedLibs = 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 LoadHelper -> (PackageName, (InstallLocation, Installed))
lhPair [LoadHelper]
installedLibs3
let exesToSM :: InstallLocation -> [PackageIdentifier] -> InstalledMap
exesToSM InstallLocation
loc = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (InstallLocation -> PackageIdentifier -> InstalledMap
exeToSM InstallLocation
loc)
exeToSM :: InstallLocation -> PackageIdentifier -> InstalledMap
exeToSM InstallLocation
loc (PackageIdentifier PackageName
name Version
version) =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
Maybe (InstallLocation, Version)
Nothing -> InstalledMap
m
Just (InstallLocation
iLoc, Version
iVersion)
| Version
version forall a. Eq a => a -> a -> Bool
/= Version
iVersion Bool -> Bool -> Bool
|| InstallLocation -> InstallLocation -> Bool
mismatchingLoc InstallLocation
loc InstallLocation
iLoc -> forall k a. Map k a
Map.empty
| Bool
otherwise -> InstalledMap
m
where
m :: InstalledMap
m = forall k a. k -> a -> Map k a
Map.singleton PackageName
name (InstallLocation
loc, PackageIdentifier -> Installed
Executable forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version)
mismatchingLoc :: InstallLocation -> InstallLocation -> Bool
mismatchingLoc InstallLocation
installed InstallLocation
target | InstallLocation
target forall a. Eq a => a -> a -> Bool
== InstallLocation
installed = Bool
False
| InstallLocation
installed forall a. Eq a => a -> a -> Bool
== InstallLocation
Local = Bool
False
| Bool
otherwise = Bool
True
[PackageIdentifier]
exesSnap <- forall env.
HasEnvConfig env =>
InstallLocation -> RIO env [PackageIdentifier]
getInstalledExes InstallLocation
Snap
[PackageIdentifier]
exesLocal <- forall env.
HasEnvConfig env =>
InstallLocation -> RIO env [PackageIdentifier]
getInstalledExes InstallLocation
Local
let installedMap :: InstalledMap
installedMap = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
[ InstallLocation -> [PackageIdentifier] -> InstalledMap
exesToSM InstallLocation
Local [PackageIdentifier]
exesLocal
, InstallLocation -> [PackageIdentifier] -> InstalledMap
exesToSM InstallLocation
Snap [PackageIdentifier]
exesSnap
, InstalledMap
installedLibs
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( InstalledMap
installedMap
, [DumpPackage]
globalDumpPkgs
, [DumpPackage]
snapshotDumpPkgs
, [DumpPackage]
localDumpPkgs
)
loadDatabase :: HasEnvConfig env
=> InstallMap
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase :: forall env.
HasEnvConfig env =>
InstallMap
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase InstallMap
installMap Maybe (InstalledPackageLocation, Path Abs Dir)
mdb [LoadHelper]
lhs0 = do
GhcPkgExe
pkgexe <- forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
([(Allowed, LoadHelper)]
lhs1', [DumpPackage]
dps) <- forall env a.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> [Path Abs Dir] -> ConduitM Text Void (RIO env) a -> RIO env a
ghcPkgDump GhcPkgExe
pkgexe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (forall a. Maybe a -> [a]
maybeToList Maybe (InstalledPackageLocation, Path Abs Dir)
mdb))
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadThrow m =>
ConduitM Text DumpPackage m ()
conduitDumpPackage forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
sink
[LoadHelper]
lhs1 <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (forall env.
HasLogFunc env =>
Maybe (InstalledPackageLocation, Path Abs Dir)
-> (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
processLoadResult Maybe (InstalledPackageLocation, Path Abs Dir)
mdb) [(Allowed, LoadHelper)]
lhs1'
let lhs :: Map GhcPkgId LoadHelper
lhs = forall name id item.
(Ord name, Ord id) =>
(id -> name)
-> (item -> id)
-> (item -> [id])
-> (item -> item -> item)
-> [item]
-> Map name item
pruneDeps
forall a. a -> a
id
LoadHelper -> GhcPkgId
lhId
LoadHelper -> [GhcPkgId]
lhDeps
forall a b. a -> b -> a
const
([LoadHelper]
lhs0 forall a. [a] -> [a] -> [a]
++ [LoadHelper]
lhs1)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a -> b) -> [a] -> [b]
map (\LoadHelper
lh -> LoadHelper
lh { lhDeps :: [GhcPkgId]
lhDeps = [] }) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map GhcPkgId LoadHelper
lhs, [DumpPackage]
dps)
where
mloc :: Maybe InstalledPackageLocation
mloc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Maybe (InstalledPackageLocation, Path Abs Dir)
mdb
sinkDP :: ConduitT DumpPackage c (RIO env) [(Allowed, LoadHelper)]
sinkDP = forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map (InstallMap
-> Maybe InstalledPackageLocation -> DumpPackage -> Allowed
isAllowed InstallMap
installMap Maybe InstalledPackageLocation
mloc forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Maybe InstalledPackageLocation -> DumpPackage -> LoadHelper
toLoadHelper Maybe InstalledPackageLocation
mloc)
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]
CL.consume
sink :: ConduitT
DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
sink = forall i (m :: * -> *) r. ZipSink i m r -> ConduitT i Void m r
getZipSink forall a b. (a -> b) -> a -> b
$ (,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink forall {c}.
ConduitT DumpPackage c (RIO env) [(Allowed, LoadHelper)]
sinkDP
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
processLoadResult :: HasLogFunc env
=> Maybe (InstalledPackageLocation, Path Abs Dir)
-> (Allowed, LoadHelper)
-> RIO env (Maybe LoadHelper)
processLoadResult :: forall env.
HasLogFunc env =>
Maybe (InstalledPackageLocation, Path Abs Dir)
-> (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
processLoadResult Maybe (InstalledPackageLocation, Path Abs Dir)
_ (Allowed
Allowed, LoadHelper
lh) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just LoadHelper
lh)
processLoadResult Maybe (InstalledPackageLocation, Path Abs Dir)
mdb (Allowed
reason, LoadHelper
lh) = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Ignoring package " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString (forall a b. (a, b) -> a
fst (LoadHelper -> (PackageName, (InstallLocation, Installed))
lhPair LoadHelper
lh))) forall a. Semigroup a => a -> a -> a
<>
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (\(InstalledPackageLocation, Path Abs Dir)
db -> Utf8Builder
", from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (InstalledPackageLocation, Path Abs Dir)
db forall a. Semigroup a => a -> a -> a
<> Utf8Builder
",") Maybe (InstalledPackageLocation, Path Abs Dir)
mdb forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" due to" forall a. Semigroup a => a -> a -> a
<>
case Allowed
reason of
Allowed
UnknownPkg -> Utf8Builder
" it being unknown to the resolver / extra-deps."
WrongLocation Maybe InstalledPackageLocation
mloc InstallLocation
loc -> Utf8Builder
" wrong location: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (Maybe InstalledPackageLocation
mloc, InstallLocation
loc)
WrongVersion Version
actual Version
wanted ->
Utf8Builder
" wanting version " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
wanted) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" instead of " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
actual)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
data Allowed
= Allowed
| UnknownPkg
| WrongLocation (Maybe InstalledPackageLocation) InstallLocation
| WrongVersion Version Version
deriving (Allowed -> Allowed -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Allowed -> Allowed -> Bool
$c/= :: Allowed -> Allowed -> Bool
== :: Allowed -> Allowed -> Bool
$c== :: Allowed -> Allowed -> Bool
Eq, Int -> Allowed -> ShowS
[Allowed] -> ShowS
Allowed -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Allowed] -> ShowS
$cshowList :: [Allowed] -> ShowS
show :: Allowed -> String
$cshow :: Allowed -> String
showsPrec :: Int -> Allowed -> ShowS
$cshowsPrec :: Int -> Allowed -> ShowS
Show)
isAllowed :: InstallMap
-> Maybe InstalledPackageLocation
-> DumpPackage
-> Allowed
isAllowed :: InstallMap
-> Maybe InstalledPackageLocation -> DumpPackage -> Allowed
isAllowed InstallMap
installMap Maybe InstalledPackageLocation
mloc DumpPackage
dp =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
Maybe (InstallLocation, Version)
Nothing ->
case DumpPackage -> Maybe PackageIdentifier
dpParentLibIdent DumpPackage
dp of
Just (PackageIdentifier PackageName
parentLibName Version
version') ->
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
parentLibName InstallMap
installMap of
Maybe (InstallLocation, Version)
Nothing -> Allowed
checkNotFound
Just (InstallLocation, Version)
instInfo
| Version
version' forall a. Eq a => a -> a -> Bool
== Version
version -> (InstallLocation, Version) -> Allowed
checkFound (InstallLocation, Version)
instInfo
| Bool
otherwise -> Allowed
checkNotFound
Maybe PackageIdentifier
Nothing -> Allowed
checkNotFound
Just (InstallLocation, Version)
pii -> (InstallLocation, Version) -> Allowed
checkFound (InstallLocation, Version)
pii
where
PackageIdentifier PackageName
name Version
version = DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp
checkLocation :: InstallLocation -> Bool
checkLocation InstallLocation
Snap = Bool
True
checkLocation InstallLocation
Local = Maybe InstalledPackageLocation
mloc forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (InstallLocation -> InstalledPackageLocation
InstalledTo InstallLocation
Local) Bool -> Bool -> Bool
|| Maybe InstalledPackageLocation
mloc forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just InstalledPackageLocation
ExtraGlobal
checkFound :: (InstallLocation, Version) -> Allowed
checkFound (InstallLocation
installLoc, Version
installVer)
| Bool -> Bool
not (InstallLocation -> Bool
checkLocation InstallLocation
installLoc) = Maybe InstalledPackageLocation -> InstallLocation -> Allowed
WrongLocation Maybe InstalledPackageLocation
mloc InstallLocation
installLoc
| Version
version forall a. Eq a => a -> a -> Bool
/= Version
installVer = Version -> Version -> Allowed
WrongVersion Version
version Version
installVer
| Bool
otherwise = Allowed
Allowed
checkNotFound :: Allowed
checkNotFound = case Maybe InstalledPackageLocation
mloc of
Maybe InstalledPackageLocation
Nothing -> Allowed
Allowed
Just InstalledPackageLocation
ExtraGlobal -> Allowed
Allowed
Just InstalledPackageLocation
_ -> Allowed
UnknownPkg
data LoadHelper = LoadHelper
{ LoadHelper -> GhcPkgId
lhId :: !GhcPkgId
, LoadHelper -> [GhcPkgId]
lhDeps :: ![GhcPkgId]
, LoadHelper -> (PackageName, (InstallLocation, Installed))
lhPair :: !(PackageName, (InstallLocation, Installed))
}
deriving Int -> LoadHelper -> ShowS
[LoadHelper] -> ShowS
LoadHelper -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoadHelper] -> ShowS
$cshowList :: [LoadHelper] -> ShowS
show :: LoadHelper -> String
$cshow :: LoadHelper -> String
showsPrec :: Int -> LoadHelper -> ShowS
$cshowsPrec :: Int -> LoadHelper -> ShowS
Show
toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage -> LoadHelper
toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage -> LoadHelper
toLoadHelper Maybe InstalledPackageLocation
mloc DumpPackage
dp = LoadHelper
{ lhId :: GhcPkgId
lhId = GhcPkgId
gid
, lhDeps :: [GhcPkgId]
lhDeps =
if PackageName
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages
then []
else DumpPackage -> [GhcPkgId]
dpDepends DumpPackage
dp
, lhPair :: (PackageName, (InstallLocation, Installed))
lhPair = (PackageName
name, (Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation Maybe InstalledPackageLocation
mloc, PackageIdentifier
-> GhcPkgId -> Maybe (Either License License) -> Installed
Library PackageIdentifier
ident GhcPkgId
gid (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DumpPackage -> Maybe License
dpLicense DumpPackage
dp)))
}
where
gid :: GhcPkgId
gid = DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp
ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
_) = DumpPackage -> PackageIdentifier
dpPackageIdent DumpPackage
dp
toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation Maybe InstalledPackageLocation
Nothing = InstallLocation
Snap
toPackageLocation (Just InstalledPackageLocation
ExtraGlobal) = InstallLocation
Snap
toPackageLocation (Just (InstalledTo InstallLocation
loc)) = InstallLocation
loc