module Stack.Build.Installed
( InstalledMap
, Installed (..)
, GetInstalledOpts (..)
, getInstalled
) where
import Data.Conduit
import qualified Data.Conduit.List as CL
import qualified Data.Foldable as F
import qualified Data.HashSet as HashSet
import Data.List
import qualified Data.Map.Strict as M
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Path
import Stack.Build.Cache
import Stack.Constants
import Stack.PackageDump
import Stack.Prelude
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.Package
import Stack.Types.PackageDump
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Version
import System.Process.Read (EnvOverride)
data GetInstalledOpts = GetInstalledOpts
{ getInstalledProfiling :: !Bool
, getInstalledHaddock :: !Bool
, getInstalledSymbols :: !Bool
}
getInstalled :: HasEnvConfig env
=> EnvOverride
-> GetInstalledOpts
-> Map PackageName PackageSource
-> RIO env
( InstalledMap
, [DumpPackage () () ()]
, [DumpPackage () () ()]
, [DumpPackage () () ()]
)
getInstalled menv opts sourceMap = do
logDebug "Finding out which packages are already installed"
snapDBPath <- packageDatabaseDeps
localDBPath <- packageDatabaseLocal
extraDBPaths <- packageDatabaseExtra
mcache <-
if getInstalledProfiling opts || getInstalledHaddock opts
then configInstalledCache >>= liftM Just . loadInstalledCache
else return Nothing
let loadDatabase' = loadDatabase menv opts mcache sourceMap
(installedLibs0, globalDumpPkgs) <- loadDatabase' Nothing []
(installedLibs1, _extraInstalled) <-
foldM (\lhs' pkgdb ->
loadDatabase' (Just (ExtraGlobal, pkgdb)) (fst lhs')
) (installedLibs0, globalDumpPkgs) extraDBPaths
(installedLibs2, snapshotDumpPkgs) <-
loadDatabase' (Just (InstalledTo Snap, snapDBPath)) installedLibs1
(installedLibs3, localDumpPkgs) <-
loadDatabase' (Just (InstalledTo Local, localDBPath)) installedLibs2
let installedLibs = M.fromList $ map lhPair installedLibs3
F.forM_ mcache $ \cache -> do
icache <- configInstalledCache
saveInstalledCache icache cache
let exesToSM loc = Map.unions . map (exeToSM loc)
exeToSM loc (PackageIdentifier name version) =
case Map.lookup name sourceMap of
Nothing -> m
Just pii
| version /= piiVersion pii || loc /= piiLocation pii -> Map.empty
| otherwise -> m
where
m = Map.singleton name (loc, Executable $ PackageIdentifier name version)
exesSnap <- getInstalledExes Snap
exesLocal <- getInstalledExes Local
let installedMap = Map.unions
[ exesToSM Local exesLocal
, exesToSM Snap exesSnap
, installedLibs
]
return ( installedMap
, globalDumpPkgs
, snapshotDumpPkgs
, localDumpPkgs
)
loadDatabase :: HasEnvConfig env
=> EnvOverride
-> GetInstalledOpts
-> Maybe InstalledCache
-> Map PackageName PackageSource
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage () () ()])
loadDatabase menv opts mcache sourceMap mdb lhs0 = do
wc <- view $ actualCompilerVersionL.to whichCompiler
(lhs1', dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb))
$ conduitDumpPackage =$ sink
let ghcjsHack = wc == Ghcjs && isNothing mdb
lhs1 <- mapMaybeM (processLoadResult mdb ghcjsHack) lhs1'
let lhs = pruneDeps
id
lhId
lhDeps
const
(lhs0 ++ lhs1)
return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, dps)
where
conduitProfilingCache =
case mcache of
Just cache | getInstalledProfiling opts -> addProfiling cache
_ -> CL.map (\dp -> dp { dpProfiling = False })
conduitHaddockCache =
case mcache of
Just cache | getInstalledHaddock opts -> addHaddock cache
_ -> CL.map (\dp -> dp { dpHaddock = False })
conduitSymbolsCache =
case mcache of
Just cache | getInstalledSymbols opts -> addSymbols cache
_ -> CL.map (\dp -> dp { dpSymbols = False })
mloc = fmap fst mdb
sinkDP = conduitProfilingCache
=$ conduitHaddockCache
=$ conduitSymbolsCache
=$ CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc)
=$ CL.consume
sink = getZipSink $ (,)
<$> ZipSink sinkDP
<*> ZipSink CL.consume
processLoadResult :: MonadLogger m
=> Maybe (InstalledPackageLocation, Path Abs Dir)
-> Bool
-> (Allowed, LoadHelper)
-> m (Maybe LoadHelper)
processLoadResult _ _ (Allowed, lh) = return (Just lh)
processLoadResult _ True (WrongVersion actual wanted, lh)
| fst (lhPair lh) `HashSet.member` ghcjsBootPackages = do
logWarn $ T.concat
[ "Ignoring that the GHCJS boot package \""
, packageNameText (fst (lhPair lh))
, "\" has a different version, "
, versionText actual
, ", than the resolver's wanted version, "
, versionText wanted
]
return (Just lh)
processLoadResult mdb _ (reason, lh) = do
logDebug $ T.concat $
[ "Ignoring package "
, packageNameText (fst (lhPair lh))
] ++
maybe [] (\db -> [", from ", T.pack (show db), ","]) mdb ++
[ " due to"
, case reason of
Allowed -> " the impossible?!?!"
NeedsProfiling -> " it needing profiling."
NeedsHaddock -> " it needing haddocks."
NeedsSymbols -> " it needing debugging symbols."
UnknownPkg -> " it being unknown to the resolver / extra-deps."
WrongLocation mloc loc -> " wrong location: " <> T.pack (show (mloc, loc))
WrongVersion actual wanted -> T.concat
[ " wanting version "
, versionText wanted
, " instead of "
, versionText actual
]
]
return Nothing
data Allowed
= Allowed
| NeedsProfiling
| NeedsHaddock
| NeedsSymbols
| UnknownPkg
| WrongLocation (Maybe InstalledPackageLocation) InstallLocation
| WrongVersion Version Version
deriving (Eq, Show)
isAllowed :: GetInstalledOpts
-> Maybe InstalledCache
-> Map PackageName PackageSource
-> Maybe InstalledPackageLocation
-> DumpPackage Bool Bool Bool
-> Allowed
isAllowed opts mcache sourceMap mloc dp
| getInstalledProfiling opts && isJust mcache && not (dpProfiling dp) = NeedsProfiling
| getInstalledHaddock opts && isJust mcache && not (dpHaddock dp) = NeedsHaddock
| getInstalledSymbols opts && isJust mcache && not (dpSymbols dp) = NeedsSymbols
| otherwise =
case Map.lookup name sourceMap of
Nothing ->
case mloc of
Nothing -> Allowed
Just ExtraGlobal -> Allowed
Just _ -> UnknownPkg
Just pii
| not (checkLocation (piiLocation pii)) -> WrongLocation mloc (piiLocation pii)
| version /= piiVersion pii -> WrongVersion version (piiVersion pii)
| otherwise -> Allowed
where
PackageIdentifier name version = dpPackageIdent dp
checkLocation Snap = mloc /= Just (InstalledTo Local)
checkLocation Local = mloc == Just (InstalledTo Local) || mloc == Just ExtraGlobal
data LoadHelper = LoadHelper
{ lhId :: !GhcPkgId
, lhDeps :: ![GhcPkgId]
, lhPair :: !(PackageName, (InstallLocation, Installed))
}
deriving Show
toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage Bool Bool Bool -> LoadHelper
toLoadHelper mloc dp = LoadHelper
{ lhId = gid
, lhDeps =
if name `HashSet.member` wiredInPackages
then []
else dpDepends dp
, lhPair = (name, (toPackageLocation mloc, Library ident gid (dpLicense dp)))
}
where
gid = dpGhcPkgId dp
ident@(PackageIdentifier name _) = dpPackageIdent dp
toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation Nothing = Snap
toPackageLocation (Just ExtraGlobal) = Snap
toPackageLocation (Just (InstalledTo loc)) = loc