{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}

-- Determine which packages are already installed

module Stack.Build.Installed
  ( InstalledMap
  , Installed (..)
  , getInstalled
  , InstallMap
  , toInstallMap
  ) where

import           Data.Conduit ( ZipSink (..), getZipSink )
import qualified Data.Conduit.List as CL
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import           Stack.Build.Cache ( getInstalledExes )
import           Stack.Constants ( wiredInPackages )
import           Stack.PackageDump
                   ( conduitDumpPackage, ghcPkgDump, pruneDeps )
import           Stack.Prelude
import           Stack.SourceMap ( getPLIVersion, loadVersion )
import           Stack.Types.CompilerPaths ( getGhcPkgExe )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig
                    ( HasEnvConfig, packageDatabaseDeps, packageDatabaseExtra
                    , packageDatabaseLocal
                    )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.Package
                   ( InstallLocation (..), InstallMap, Installed (..)
                   , InstalledMap, InstalledPackageLocation (..)
                   )
import           Stack.Types.SourceMap
                   ( DepPackage (..), ProjectPackage (..), SourceMap (..) )

toInstallMap :: MonadIO m => SourceMap -> m InstallMap
toInstallMap :: forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap = do
  InstallMap
projectInstalls <-
    Map PackageName ProjectPackage
-> (ProjectPackage -> m (InstallLocation, Version)) -> m InstallMap
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) ((ProjectPackage -> m (InstallLocation, Version)) -> m InstallMap)
-> (ProjectPackage -> m (InstallLocation, Version)) -> m InstallMap
forall a b. (a -> b) -> a -> b
$ \ProjectPackage
pp -> do
      Version
version <- CommonPackage -> m Version
forall (m :: * -> *). MonadIO m => CommonPackage -> m Version
loadVersion (ProjectPackage -> CommonPackage
ppCommon ProjectPackage
pp)
      (InstallLocation, Version) -> m (InstallLocation, Version)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Local, Version
version)
  InstallMap
depInstalls <-
    Map PackageName DepPackage
-> (DepPackage -> m (InstallLocation, Version)) -> m InstallMap
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) ((DepPackage -> m (InstallLocation, Version)) -> m InstallMap)
-> (DepPackage -> m (InstallLocation, Version)) -> m InstallMap
forall a b. (a -> b) -> a -> b
$ \DepPackage
dp ->
      case DepPackage -> PackageLocation
dpLocation DepPackage
dp of
        PLImmutable PackageLocationImmutable
pli -> (InstallLocation, Version) -> m (InstallLocation, Version)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Snap, PackageLocationImmutable -> Version
getPLIVersion PackageLocationImmutable
pli)
        PLMutable ResolvedPath Dir
_ -> do
          Version
version <- CommonPackage -> m Version
forall (m :: * -> *). MonadIO m => CommonPackage -> m Version
loadVersion (DepPackage -> CommonPackage
dpCommon DepPackage
dp)
          (InstallLocation, Version) -> m (InstallLocation, Version)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Local, Version
version)
  InstallMap -> m InstallMap
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallMap -> m InstallMap) -> InstallMap -> m InstallMap
forall a b. (a -> b) -> a -> b
$ InstallMap
projectInstalls InstallMap -> InstallMap -> InstallMap
forall a. Semigroup a => a -> a -> a
<> InstallMap
depInstalls

-- | Returns the new InstalledMap and all of the locally registered packages.

getInstalled :: HasEnvConfig env
             => InstallMap -- ^ does not contain any installed information

             -> RIO env
                  ( InstalledMap
                  , [DumpPackage] -- globally installed

                  , [DumpPackage] -- snapshot installed

                  , [DumpPackage] -- locally installed

                  )
getInstalled :: forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled {-opts-} InstallMap
installMap = do
  Utf8Builder -> RIO env ()
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 <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseDeps
  Path Abs Dir
localDBPath <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
  [Path Abs Dir]
extraDBPaths <- RIO env [Path Abs Dir]
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m) =>
m [Path Abs Dir]
packageDatabaseExtra

  let loadDatabase' :: Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' = InstallMap
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase {-opts mcache-} InstallMap
installMap

  ([LoadHelper]
installedLibs0, [DumpPackage]
globalDumpPkgs) <- Maybe (InstalledPackageLocation, Path Abs Dir)
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' Maybe (InstalledPackageLocation, Path Abs Dir)
forall a. Maybe a
Nothing []
  ([LoadHelper]
installedLibs1, [DumpPackage]
_extraInstalled) <-
    (([LoadHelper], [DumpPackage])
 -> Path Abs Dir -> RIO env ([LoadHelper], [DumpPackage]))
-> ([LoadHelper], [DumpPackage])
-> [Path Abs Dir]
-> RIO env ([LoadHelper], [DumpPackage])
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' ((InstalledPackageLocation, Path Abs Dir)
-> Maybe (InstalledPackageLocation, Path Abs Dir)
forall a. a -> Maybe a
Just (InstalledPackageLocation
ExtraGlobal, Path Abs Dir
pkgdb)) (([LoadHelper], [DumpPackage]) -> [LoadHelper]
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' ((InstalledPackageLocation, Path Abs Dir)
-> Maybe (InstalledPackageLocation, Path Abs Dir)
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' ((InstalledPackageLocation, Path Abs Dir)
-> Maybe (InstalledPackageLocation, Path Abs Dir)
forall a. a -> Maybe a
Just (InstallLocation -> InstalledPackageLocation
InstalledTo InstallLocation
Local, Path Abs Dir
localDBPath)) [LoadHelper]
installedLibs2
  let installedLibs :: InstalledMap
installedLibs = [(PackageName, (InstallLocation, Installed))] -> InstalledMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, (InstallLocation, Installed))] -> InstalledMap)
-> [(PackageName, (InstallLocation, Installed))] -> InstalledMap
forall a b. (a -> b) -> a -> b
$ (LoadHelper -> (PackageName, (InstallLocation, Installed)))
-> [LoadHelper] -> [(PackageName, (InstallLocation, Installed))]
forall a b. (a -> b) -> [a] -> [b]
map LoadHelper -> (PackageName, (InstallLocation, Installed))
lhPair [LoadHelper]
installedLibs3

  -- Add in the executables that are installed, making sure to only trust a

  -- listed installation under the right circumstances (see below)

  let exesToSM :: InstallLocation -> [PackageIdentifier] -> InstalledMap
exesToSM InstallLocation
loc = [InstalledMap] -> InstalledMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([InstalledMap] -> InstalledMap)
-> ([PackageIdentifier] -> [InstalledMap])
-> [PackageIdentifier]
-> InstalledMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifier -> InstalledMap)
-> [PackageIdentifier] -> [InstalledMap]
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 PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
          -- Doesn't conflict with anything, so that's OK

          Maybe (InstallLocation, Version)
Nothing -> InstalledMap
m
          Just (InstallLocation
iLoc, Version
iVersion)
            -- Not the version we want, ignore it

            | Version
version Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
iVersion Bool -> Bool -> Bool
|| InstallLocation -> InstallLocation -> Bool
mismatchingLoc InstallLocation
loc InstallLocation
iLoc -> InstalledMap
forall k a. Map k a
Map.empty
            | Bool
otherwise -> InstalledMap
m
       where
        m :: InstalledMap
m = PackageName -> (InstallLocation, Installed) -> InstalledMap
forall k a. k -> a -> Map k a
Map.singleton PackageName
name (InstallLocation
loc, PackageIdentifier -> Installed
Executable (PackageIdentifier -> Installed) -> PackageIdentifier -> Installed
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 InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
installed = Bool
False
          | InstallLocation
installed InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Local = Bool
False -- snapshot dependency could end up

                                       -- in a local install as being mutable

          | Bool
otherwise = Bool
True
  [PackageIdentifier]
exesSnap <- InstallLocation -> RIO env [PackageIdentifier]
forall env.
HasEnvConfig env =>
InstallLocation -> RIO env [PackageIdentifier]
getInstalledExes InstallLocation
Snap
  [PackageIdentifier]
exesLocal <- InstallLocation -> RIO env [PackageIdentifier]
forall env.
HasEnvConfig env =>
InstallLocation -> RIO env [PackageIdentifier]
getInstalledExes InstallLocation
Local
  let installedMap :: InstalledMap
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
        ]

  (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( InstalledMap
installedMap
       , [DumpPackage]
globalDumpPkgs
       , [DumpPackage]
snapshotDumpPkgs
       , [DumpPackage]
localDumpPkgs
       )

-- | Outputs both the modified InstalledMap and the Set of all installed

-- packages in this database

--

-- The goal is to ascertain that the dependencies for a package are present,

-- that it has profiling if necessary, and that it matches the version and

-- location needed by the SourceMap

loadDatabase ::
     HasEnvConfig env
  => InstallMap -- ^ to determine which installed things we should include

  -> Maybe (InstalledPackageLocation, Path Abs Dir)
     -- ^ package database, Nothing for global

  -> [LoadHelper] -- ^ from parent databases

  -> 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 <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
  ([(Allowed, LoadHelper)]
lhs1', [DumpPackage]
dps) <- GhcPkgExe
-> [Path Abs Dir]
-> ConduitM
     Text Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> RIO env ([(Allowed, LoadHelper)], [DumpPackage])
forall env a.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir] -> ConduitM Text Void (RIO env) a -> RIO env a
ghcPkgDump GhcPkgExe
pkgexe (((InstalledPackageLocation, Path Abs Dir) -> Path Abs Dir)
-> [(InstalledPackageLocation, Path Abs Dir)] -> [Path Abs Dir]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InstalledPackageLocation, Path Abs Dir) -> Path Abs Dir
forall a b. (a, b) -> b
snd (Maybe (InstalledPackageLocation, Path Abs Dir)
-> [(InstalledPackageLocation, Path Abs Dir)]
forall a. Maybe a -> [a]
maybeToList Maybe (InstalledPackageLocation, Path Abs Dir)
mdb)) (ConduitM
   Text Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
 -> RIO env ([(Allowed, LoadHelper)], [DumpPackage]))
-> ConduitM
     Text Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> RIO env ([(Allowed, LoadHelper)], [DumpPackage])
forall a b. (a -> b) -> a -> b
$
                    ConduitM Text DumpPackage (RIO env) ()
forall (m :: * -> *).
MonadThrow m =>
ConduitM Text DumpPackage m ()
conduitDumpPackage ConduitM Text DumpPackage (RIO env) ()
-> ConduitT
     DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitM
     Text Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
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 <- ((Allowed, LoadHelper) -> RIO env (Maybe LoadHelper))
-> [(Allowed, LoadHelper)] -> RIO env [LoadHelper]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Maybe (InstalledPackageLocation, Path Abs Dir)
-> (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
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 = (GhcPkgId -> GhcPkgId)
-> (LoadHelper -> GhcPkgId)
-> (LoadHelper -> [GhcPkgId])
-> (LoadHelper -> LoadHelper -> LoadHelper)
-> [LoadHelper]
-> Map GhcPkgId LoadHelper
forall name id item.
(Ord name, Ord id) =>
(id -> name)
-> (item -> id)
-> (item -> [id])
-> (item -> item -> item)
-> [item]
-> Map name item
pruneDeps GhcPkgId -> GhcPkgId
forall a. a -> a
id LoadHelper -> GhcPkgId
lhId LoadHelper -> [GhcPkgId]
lhDeps LoadHelper -> LoadHelper -> LoadHelper
forall a b. a -> b -> a
const ([LoadHelper]
lhs0 [LoadHelper] -> [LoadHelper] -> [LoadHelper]
forall a. [a] -> [a] -> [a]
++ [LoadHelper]
lhs1)
  ([LoadHelper], [DumpPackage])
-> RIO env ([LoadHelper], [DumpPackage])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LoadHelper -> LoadHelper) -> [LoadHelper] -> [LoadHelper]
forall a b. (a -> b) -> [a] -> [b]
map (\LoadHelper
lh -> LoadHelper
lh { lhDeps :: [GhcPkgId]
lhDeps = [] }) ([LoadHelper] -> [LoadHelper]) -> [LoadHelper] -> [LoadHelper]
forall a b. (a -> b) -> a -> b
$ Map GhcPkgId LoadHelper -> [LoadHelper]
forall k a. Map k a -> [a]
Map.elems Map GhcPkgId LoadHelper
lhs, [DumpPackage]
dps)
 where
  mloc :: Maybe InstalledPackageLocation
mloc = ((InstalledPackageLocation, Path Abs Dir)
 -> InstalledPackageLocation)
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> Maybe InstalledPackageLocation
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InstalledPackageLocation, Path Abs Dir)
-> InstalledPackageLocation
forall a b. (a, b) -> a
fst Maybe (InstalledPackageLocation, Path Abs Dir)
mdb
  sinkDP :: ConduitT DumpPackage c (RIO env) [(Allowed, LoadHelper)]
sinkDP =  (DumpPackage -> (Allowed, LoadHelper))
-> ConduitT DumpPackage (Allowed, LoadHelper) (RIO env) ()
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 (DumpPackage -> Allowed)
-> (DumpPackage -> LoadHelper)
-> DumpPackage
-> (Allowed, LoadHelper)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
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)
         ConduitT DumpPackage (Allowed, LoadHelper) (RIO env) ()
-> ConduitT
     (Allowed, LoadHelper) c (RIO env) [(Allowed, LoadHelper)]
-> ConduitT DumpPackage c (RIO env) [(Allowed, LoadHelper)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT (Allowed, LoadHelper) c (RIO env) [(Allowed, LoadHelper)]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
  sink :: ConduitT
  DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
sink =   ZipSink
  DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitT
     DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall i (m :: * -> *) r. ZipSink i m r -> ConduitT i Void m r
getZipSink (ZipSink
   DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
 -> ConduitT
      DumpPackage
      Void
      (RIO env)
      ([(Allowed, LoadHelper)], [DumpPackage]))
-> ZipSink
     DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitT
     DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall a b. (a -> b) -> a -> b
$ (,)
       ([(Allowed, LoadHelper)]
 -> [DumpPackage] -> ([(Allowed, LoadHelper)], [DumpPackage]))
-> ZipSink DumpPackage (RIO env) [(Allowed, LoadHelper)]
-> ZipSink
     DumpPackage
     (RIO env)
     ([DumpPackage] -> ([(Allowed, LoadHelper)], [DumpPackage]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT DumpPackage Void (RIO env) [(Allowed, LoadHelper)]
-> ZipSink DumpPackage (RIO env) [(Allowed, LoadHelper)]
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink ConduitT DumpPackage Void (RIO env) [(Allowed, LoadHelper)]
forall {c}.
ConduitT DumpPackage c (RIO env) [(Allowed, LoadHelper)]
sinkDP
       ZipSink
  DumpPackage
  (RIO env)
  ([DumpPackage] -> ([(Allowed, LoadHelper)], [DumpPackage]))
-> ZipSink DumpPackage (RIO env) [DumpPackage]
-> ZipSink
     DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall a b.
ZipSink DumpPackage (RIO env) (a -> b)
-> ZipSink DumpPackage (RIO env) a
-> ZipSink DumpPackage (RIO env) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitT DumpPackage Void (RIO env) [DumpPackage]
-> ZipSink DumpPackage (RIO env) [DumpPackage]
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink ConduitT DumpPackage Void (RIO env) [DumpPackage]
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) = Maybe LoadHelper -> RIO env (Maybe LoadHelper)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoadHelper -> Maybe LoadHelper
forall a. a -> Maybe a
Just LoadHelper
lh)
processLoadResult Maybe (InstalledPackageLocation, Path Abs Dir)
mdb (Allowed
reason, LoadHelper
lh) = do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
       Utf8Builder
"Ignoring package "
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString ((PackageName, (InstallLocation, Installed)) -> PackageName
forall a b. (a, b) -> a
fst (LoadHelper -> (PackageName, (InstallLocation, Installed))
lhPair LoadHelper
lh)))
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
-> ((InstalledPackageLocation, Path Abs Dir) -> Utf8Builder)
-> Maybe (InstalledPackageLocation, Path Abs Dir)
-> Utf8Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
         Utf8Builder
forall a. Monoid a => a
mempty
         ( \(InstalledPackageLocation, Path Abs Dir)
db ->    Utf8Builder
", from "
                  Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (InstalledPackageLocation, Path Abs Dir) -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (InstalledPackageLocation, Path Abs Dir)
db
                  Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
","
         )
         Maybe (InstalledPackageLocation, Path Abs Dir)
mdb
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" due to"
    Utf8Builder -> Utf8Builder -> Utf8Builder
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: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (Maybe InstalledPackageLocation, InstallLocation) -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (Maybe InstalledPackageLocation
mloc, InstallLocation
loc)
         WrongVersion Version
actual Version
wanted ->
              Utf8Builder
" wanting version "
          Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
wanted)
          Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" instead of "
          Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
actual)
  Maybe LoadHelper -> RIO env (Maybe LoadHelper)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LoadHelper
forall a. Maybe a
Nothing

data Allowed
  = Allowed
  | UnknownPkg
  | WrongLocation (Maybe InstalledPackageLocation) InstallLocation
  | WrongVersion Version Version
  deriving (Allowed -> Allowed -> Bool
(Allowed -> Allowed -> Bool)
-> (Allowed -> Allowed -> Bool) -> Eq Allowed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Allowed -> Allowed -> Bool
== :: Allowed -> Allowed -> Bool
$c/= :: Allowed -> Allowed -> Bool
/= :: Allowed -> Allowed -> Bool
Eq, Int -> Allowed -> ShowS
[Allowed] -> ShowS
Allowed -> String
(Int -> Allowed -> ShowS)
-> (Allowed -> String) -> ([Allowed] -> ShowS) -> Show Allowed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Allowed -> ShowS
showsPrec :: Int -> Allowed -> ShowS
$cshow :: Allowed -> String
show :: Allowed -> String
$cshowList :: [Allowed] -> ShowS
showList :: [Allowed] -> ShowS
Show)

-- | Check if a can be included in the set of installed packages or not, based

-- on the package selections made by the user. This does not perform any

-- dirtiness or flag change checks.

isAllowed :: InstallMap
          -> Maybe InstalledPackageLocation
          -> DumpPackage
          -> Allowed
isAllowed :: InstallMap
-> Maybe InstalledPackageLocation -> DumpPackage -> Allowed
isAllowed InstallMap
installMap Maybe InstalledPackageLocation
mloc DumpPackage
dp = case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
  Maybe (InstallLocation, Version)
Nothing ->
    -- If the sourceMap has nothing to say about this package,

    -- check if it represents a sublibrary first

    -- See: https://github.com/commercialhaskell/stack/issues/3899

    case DumpPackage -> Maybe PackageIdentifier
dpParentLibIdent DumpPackage
dp of
      Just (PackageIdentifier PackageName
parentLibName Version
version') ->
        case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
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' Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version -> (InstallLocation, Version) -> Allowed
checkFound (InstallLocation, Version)
instInfo
            | Bool
otherwise -> Allowed
checkNotFound -- different versions

      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
  -- Ensure that the installed location matches where the sourceMap says it

  -- should be installed

  checkLocation :: InstallLocation -> Bool
checkLocation InstallLocation
Snap = Bool
True -- snapshot deps could become mutable after getting

                            -- any mutable dependency

  checkLocation InstallLocation
Local =
    Maybe InstalledPackageLocation
mloc Maybe InstalledPackageLocation
-> Maybe InstalledPackageLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstalledPackageLocation -> Maybe InstalledPackageLocation
forall a. a -> Maybe a
Just (InstallLocation -> InstalledPackageLocation
InstalledTo InstallLocation
Local) Bool -> Bool -> Bool
|| Maybe InstalledPackageLocation
mloc Maybe InstalledPackageLocation
-> Maybe InstalledPackageLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstalledPackageLocation -> Maybe InstalledPackageLocation
forall a. a -> Maybe a
Just InstalledPackageLocation
ExtraGlobal -- 'locally' installed snapshot packages can come from extra dbs

  -- Check if a package is allowed if it is found in the sourceMap

  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 Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
installVer = Version -> Version -> Allowed
WrongVersion Version
version Version
installVer
    | Bool
otherwise = Allowed
Allowed
  -- check if a package is allowed if it is not found in the sourceMap

  checkNotFound :: Allowed
checkNotFound = case Maybe InstalledPackageLocation
mloc of
    -- The sourceMap has nothing to say about this global package, so we can use it

    Maybe InstalledPackageLocation
Nothing -> Allowed
Allowed
    Just InstalledPackageLocation
ExtraGlobal -> Allowed
Allowed
    -- For non-global packages, don't include unknown packages.

    -- See: https://github.com/commercialhaskell/stack/issues/292

    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
(Int -> LoadHelper -> ShowS)
-> (LoadHelper -> String)
-> ([LoadHelper] -> ShowS)
-> Show LoadHelper
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoadHelper -> ShowS
showsPrec :: Int -> LoadHelper -> ShowS
$cshow :: LoadHelper -> String
show :: LoadHelper -> String
$cshowList :: [LoadHelper] -> ShowS
showList :: [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 =
      -- We always want to consider the wired in packages as having all of their

      -- dependencies installed, since we have no ability to reinstall them.

      -- This is especially important for using different minor versions of GHC,

      -- where the dependencies of wired-in packages may change slightly and

      -- therefore not match the snapshot.

      if PackageName
name PackageName -> Set PackageName -> Bool
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 (License -> Either License License
forall a b. b -> Either a b
Right (License -> Either License License)
-> Maybe License -> Maybe (Either License License)
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