{-# 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 Data.List
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.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.Package
import Stack.Types.SourceMap
toInstallMap :: MonadIO m => SourceMap -> m InstallMap
toInstallMap sourceMap = do
projectInstalls <-
for (smProject sourceMap) $ \pp -> do
version <- loadVersion (ppCommon pp)
return (Local, version)
depInstalls <-
for (smDeps sourceMap) $ \dp ->
case dpLocation dp of
PLImmutable pli -> pure (Snap, getPLIVersion pli)
PLMutable _ -> do
version <- loadVersion (dpCommon dp)
return (Local, version)
return $ projectInstalls <> depInstalls
getInstalled :: HasEnvConfig env
=> InstallMap
-> RIO env
( InstalledMap
, [DumpPackage]
, [DumpPackage]
, [DumpPackage]
)
getInstalled installMap = do
logDebug "Finding out which packages are already installed"
snapDBPath <- packageDatabaseDeps
localDBPath <- packageDatabaseLocal
extraDBPaths <- packageDatabaseExtra
let loadDatabase' = loadDatabase installMap
(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 = Map.fromList $ map lhPair installedLibs3
let exesToSM loc = Map.unions . map (exeToSM loc)
exeToSM loc (PackageIdentifier name version) =
case Map.lookup name installMap of
Nothing -> m
Just (iLoc, iVersion)
| version /= iVersion || mismatchingLoc loc iLoc -> Map.empty
| otherwise -> m
where
m = Map.singleton name (loc, Executable $ PackageIdentifier name version)
mismatchingLoc installed target | target == installed = False
| installed == Local = False
| otherwise = True
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
=> InstallMap
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase installMap mdb lhs0 = do
wc <- view $ actualCompilerVersionL.to whichCompiler
pkgexe <- getGhcPkgExe
(lhs1', dps) <- ghcPkgDump pkgexe (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
mloc = fmap fst mdb
sinkDP = CL.map (isAllowed installMap mloc &&& toLoadHelper mloc)
.| CL.consume
sink = getZipSink $ (,)
<$> ZipSink sinkDP
<*> ZipSink CL.consume
processLoadResult :: HasLogFunc env
=> Maybe (InstalledPackageLocation, Path Abs Dir)
-> Bool
-> (Allowed, LoadHelper)
-> RIO env (Maybe LoadHelper)
processLoadResult _ _ (Allowed, lh) = return (Just lh)
processLoadResult _ True (WrongVersion actual wanted, lh)
| fst (lhPair lh) `Set.member` ghcjsBootPackages = do
logWarn $
"Ignoring that the GHCJS boot package \"" <>
fromString (packageNameString (fst (lhPair lh))) <>
"\" has a different version, " <>
fromString (versionString actual) <>
", than the resolver's wanted version, " <>
fromString (versionString wanted)
return (Just lh)
processLoadResult mdb _ (reason, lh) = do
logDebug $
"Ignoring package " <>
fromString (packageNameString (fst (lhPair lh))) <>
maybe mempty (\db -> ", from " <> displayShow db <> ",") mdb <>
" due to" <>
case reason of
Allowed -> " the impossible?!?!"
UnknownPkg -> " it being unknown to the resolver / extra-deps."
WrongLocation mloc loc -> " wrong location: " <> displayShow (mloc, loc)
WrongVersion actual wanted ->
" wanting version " <>
fromString (versionString wanted) <>
" instead of " <>
fromString (versionString actual)
return Nothing
data Allowed
= Allowed
| UnknownPkg
| WrongLocation (Maybe InstalledPackageLocation) InstallLocation
| WrongVersion Version Version
deriving (Eq, Show)
isAllowed :: InstallMap
-> Maybe InstalledPackageLocation
-> DumpPackage
-> Allowed
isAllowed installMap mloc dp =
case Map.lookup name installMap of
Nothing ->
case dpParentLibIdent dp of
Just (PackageIdentifier parentLibName version') ->
case Map.lookup parentLibName installMap of
Nothing -> checkNotFound
Just instInfo
| version' == version -> checkFound instInfo
| otherwise -> checkNotFound
Nothing -> checkNotFound
Just pii -> checkFound pii
where
PackageIdentifier name version = dpPackageIdent dp
checkLocation Snap = True
checkLocation Local = mloc == Just (InstalledTo Local) || mloc == Just ExtraGlobal
checkFound (installLoc, installVer)
| not (checkLocation installLoc) = WrongLocation mloc installLoc
| version /= installVer = WrongVersion version installVer
| otherwise = Allowed
checkNotFound = case mloc of
Nothing -> Allowed
Just ExtraGlobal -> Allowed
Just _ -> UnknownPkg
data LoadHelper = LoadHelper
{ lhId :: !GhcPkgId
, lhDeps :: ![GhcPkgId]
, lhPair :: !(PackageName, (InstallLocation, Installed))
}
deriving Show
toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage -> LoadHelper
toLoadHelper mloc dp = LoadHelper
{ lhId = gid
, lhDeps =
if name `Set.member` wiredInPackages
then []
else dpDepends dp
, lhPair = (name, (toPackageLocation mloc, Library ident gid (Right <$> 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