module Stack.Build.Installed
( InstalledMap
, Installed (..)
, GetInstalledOpts (..)
, getInstalled
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Catch (MonadCatch, MonadMask)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Resource
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Function
import qualified Data.Foldable as F
import qualified Data.HashSet as HashSet
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Maybe.Extra (mapMaybeM)
import Data.Monoid
import qualified Data.Text as T
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Prelude hiding (FilePath, writeFile)
import Stack.Build.Cache
import Stack.Types.Build
import Stack.Types.Version
import Stack.Constants
import Stack.GhcPkg
import Stack.PackageDump
import Stack.Types
import Stack.Types.Internal
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasEnvConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env)
data GetInstalledOpts = GetInstalledOpts
{ getInstalledProfiling :: !Bool
, getInstalledHaddock :: !Bool
}
getInstalled :: (M env m, PackageInstallInfo pii)
=> EnvOverride
-> GetInstalledOpts
-> Map PackageName pii
-> m ( InstalledMap
, [DumpPackage () ()]
, [DumpPackage () ()]
, [DumpPackage () ()]
)
getInstalled menv opts sourceMap = do
snapDBPath <- packageDatabaseDeps
localDBPath <- packageDatabaseLocal
extraDBPaths <- packageDatabaseExtra
bconfig <- asks getBuildConfig
mcache <-
if getInstalledProfiling opts || getInstalledHaddock opts
then liftM Just $ loadInstalledCache $ configInstalledCache bconfig
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 (saveInstalledCache (configInstalledCache bconfig))
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 :: (M env m, PackageInstallInfo pii)
=> EnvOverride
-> GetInstalledOpts
-> Maybe InstalledCache
-> Map PackageName pii
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> m ([LoadHelper], [DumpPackage () ()])
loadDatabase menv opts mcache sourceMap mdb lhs0 = do
wc <- getWhichCompiler
(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 })
mloc = fmap fst mdb
sinkDP = conduitProfilingCache
=$ conduitHaddockCache
=$ CL.map (\dp -> (isAllowed opts mcache sourceMap mloc dp, toLoadHelper mloc dp))
=$ 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."
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
| UnknownPkg
| WrongLocation (Maybe InstalledPackageLocation) InstallLocation
| WrongVersion Version Version
deriving (Eq, Show)
isAllowed :: PackageInstallInfo pii
=> GetInstalledOpts
-> Maybe InstalledCache
-> Map PackageName pii
-> Maybe InstalledPackageLocation
-> DumpPackage 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
| 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 -> LoadHelper
toLoadHelper mloc dp = LoadHelper
{ lhId = gid
, lhDeps =
if name `HashSet.member` wiredInPackages
then []
else dpDepends dp
, lhPair = (name, (toPackageLocation mloc, Library ident gid))
}
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