{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.Build.Installed
( InstalledMap
, Installed (..)
, GetInstalledOpts (..)
, getInstalled
) where
import Control.Applicative
import Control.Arrow ((&&&))
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.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 Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Prelude hiding (FilePath, writeFile)
import Stack.Build.Cache
import Stack.Types.Build
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 LoadHelper = LoadHelper
{ lhId :: !GhcPkgId
, lhDeps :: ![GhcPkgId]
, lhPair :: !(PackageName, (Version, InstallLocation, Installed))
}
deriving Show
data GetInstalledOpts = GetInstalledOpts
{ getInstalledProfiling :: !Bool
, getInstalledHaddock :: !Bool
}
getInstalled :: (M env m, PackageInstallInfo pii)
=> EnvOverride
-> GetInstalledOpts
-> Map PackageName pii
-> m ( InstalledMap
, [DumpPackage () ()]
, Map GhcPkgId PackageIdentifier
)
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, globalInstalled) <- loadDatabase' Nothing []
(installedLibs1, _extraInstalled) <-
(foldM (\lhs' pkgdb -> do
lhs'' <- loadDatabase' (Just (ExtraGlobal, pkgdb)) (fst lhs')
return lhs'') ((installedLibs0, globalInstalled)) extraDBPaths)
(installedLibs2, _snapInstalled) <-
loadDatabase' (Just (InstalledTo Snap, snapDBPath)) installedLibs1
(installedLibs3, localInstalled) <-
loadDatabase' (Just (InstalledTo Local, localDBPath)) installedLibs2
let installedLibs = M.fromList $ map lhPair installedLibs3
case mcache of
Nothing -> return ()
Just pcache -> saveInstalledCache (configInstalledCache bconfig) pcache
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 (version, loc, Executable $ PackageIdentifier name version)
exesSnap <- getInstalledExes Snap
exesLocal <- getInstalledExes Local
let installedMap = Map.unions
[ exesToSM Local exesLocal
, exesToSM Snap exesSnap
, installedLibs
]
return ( installedMap
, globalInstalled
, Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localInstalled
)
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 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 })
sinkDP = conduitProfilingCache
=$ conduitHaddockCache
=$ CL.mapMaybe (isAllowed opts mcache sourceMap (fmap fst mdb))
=$ CL.consume
sink = getZipSink $ (,)
<$> ZipSink sinkDP
<*> ZipSink CL.consume
isAllowed :: PackageInstallInfo pii
=> GetInstalledOpts
-> Maybe InstalledCache
-> Map PackageName pii
-> Maybe InstalledPackageLocation
-> DumpPackage Bool Bool
-> Maybe LoadHelper
isAllowed opts mcache sourceMap mloc dp
| getInstalledProfiling opts && isJust mcache && not (dpProfiling dp) = Nothing
| getInstalledHaddock opts && isJust mcache && not (dpHaddock dp) = Nothing
| toInclude = Just LoadHelper
{ lhId = gid
, lhDeps =
if name `HashSet.member` wiredInPackages
then []
else dpDepends dp
, lhPair = (name, (version, toPackageLocation mloc, Library ident gid))
}
| otherwise = Nothing
where
toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation
toPackageLocation Nothing = Snap
toPackageLocation (Just ExtraGlobal) = Snap
toPackageLocation (Just (InstalledTo loc)) = loc
toInclude =
case Map.lookup name sourceMap of
Nothing ->
case mloc of
Nothing -> True
Just ExtraGlobal -> True
Just _ -> False
Just pii ->
version == piiVersion pii
&& checkLocation (piiLocation pii)
checkLocation Snap = mloc /= Just (InstalledTo Local)
checkLocation Local = mloc == Just (InstalledTo Local) || mloc == Just ExtraGlobal
gid = dpGhcPkgId dp
ident@(PackageIdentifier name version) = dpPackageIdent dp