diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 8376f419e8..56de23ee05 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -122,12 +122,14 @@ mkBaseConfigOpts bopts = do localDBPath <- packageDatabaseLocal snapInstallRoot <- installationRootDeps localInstallRoot <- installationRootLocal + packageExtraDBs <- packageDatabaseExtra return BaseConfigOpts { bcoSnapDB = snapDBPath , bcoLocalDB = localDBPath , bcoSnapInstallRoot = snapInstallRoot , bcoLocalInstallRoot = localInstallRoot , bcoBuildOpts = bopts + , bcoExtraDBs = packageExtraDBs } -- | Provide a function for loading package information from the package index diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index ac10129cad..25228463c9 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -716,13 +716,16 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md $ Set.toList $ addGlobalPackages deps eeGlobalPackages in - "-clear-package-db" - : "-global-package-db" - : ("-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts)) - : ("-package-db=" ++ toFilePath (bcoLocalDB eeBaseConfigOpts)) - : "-hide-all-packages" - : cabalPackageArg - : map ("-package-id=" ++) depsMinusCabal + ( "-clear-package-db" + : "-global-package-db" + : map (("-package-db=" ++) . toFilePath) (bcoExtraDBs eeBaseConfigOpts) + ) ++ + ( ("-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts)) + : ("-package-db=" ++ toFilePath (bcoLocalDB eeBaseConfigOpts)) + : "-hide-all-packages" + : cabalPackageArg + : map ("-package-id=" ++) depsMinusCabal + ) -- This branch is debatable. It adds access to the -- snapshot package database for Cabal. There are two -- possible objections: diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index f4da4bf917..6585599e80 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -- Determine which packages are already installed module Stack.Build.Installed @@ -69,6 +70,7 @@ getInstalled :: (M env m, PackageInstallInfo pii) getInstalled menv opts sourceMap = do snapDBPath <- packageDatabaseDeps localDBPath <- packageDatabaseLocal + extraDBPaths <- packageDatabaseExtra bconfig <- asks getBuildConfig @@ -78,12 +80,17 @@ getInstalled menv opts sourceMap = do else return Nothing let loadDatabase' = loadDatabase menv opts mcache sourceMap + (installedLibs0, globalInstalled) <- loadDatabase' Nothing [] - (installedLibs1, _snapInstalled) <- - loadDatabase' (Just (Snap, snapDBPath)) installedLibs0 - (installedLibs2, localInstalled) <- - loadDatabase' (Just (Local, localDBPath)) installedLibs1 - let installedLibs = M.fromList $ map lhPair installedLibs2 + (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 () @@ -126,13 +133,14 @@ loadDatabase :: (M env m, PackageInstallInfo pii) -> GetInstalledOpts -> Maybe InstalledCache -- ^ if Just, profiling or haddock is required -> Map PackageName pii -- ^ to determine which installed things we should include - -> Maybe (InstallLocation, Path Abs Dir) -- ^ package database, Nothing for global + -> Maybe (InstalledPackageLocation, Path Abs Dir) -- ^ package database, Nothing for global -> [LoadHelper] -- ^ from parent databases -> m ([LoadHelper], [DumpPackage () ()]) loadDatabase menv opts mcache sourceMap mdb lhs0 = do wc <- getWhichCompiler - (lhs1, dps) <- ghcPkgDump menv wc (fmap snd mdb) - $ conduitDumpPackage =$ sink + (lhs1, dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb)) + $ conduitDumpPackage =$ sink + let lhs = pruneDeps id lhId @@ -168,7 +176,7 @@ isAllowed :: PackageInstallInfo pii => GetInstalledOpts -> Maybe InstalledCache -> Map PackageName pii - -> Maybe InstallLocation + -> Maybe InstalledPackageLocation -> DumpPackage Bool Bool -> Maybe LoadHelper isAllowed opts mcache sourceMap mloc dp @@ -188,10 +196,15 @@ isAllowed opts mcache sourceMap mloc dp if name `HashSet.member` wiredInPackages then [] else dpDepends dp - , lhPair = (name, (version, fromMaybe Snap mloc, Library ident gid)) + , 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 -> @@ -199,6 +212,7 @@ isAllowed opts mcache sourceMap mloc dp -- The sourceMap has nothing to say about this global -- package, so we can use it Nothing -> True + Just ExtraGlobal -> True -- For non-global packages, don't include unknown packages. -- See: -- https://github.com/commercialhaskell/stack/issues/292 @@ -210,8 +224,8 @@ isAllowed opts mcache sourceMap mloc dp -- Ensure that the installed location matches where the sourceMap says it -- should be installed - checkLocation Snap = mloc /= Just Local -- we can allow either global or snap - checkLocation Local = mloc == Just Local + checkLocation Snap = mloc /= Just (InstalledTo Local) -- we can allow either global or snap + checkLocation Local = mloc == Just (InstalledTo Local) || mloc == Just ExtraGlobal -- 'locally' installed snapshot packages can come from extra dbs gid = dpGhcPkgId dp ident@(PackageIdentifier name version) = dpPackageIdent dp diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 91f1853a10..2a6e6ba3e3 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -80,7 +80,6 @@ loadSourceMap needTargets bopts = do bconfig <- asks getBuildConfig rawLocals <- getLocalPackageViews (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets bopts - menv <- getMinimalEnvOverride caches <- getPackageCaches menv let latestVersion = Map.fromListWith max $ map toTuple $ Map.keys caches diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 06581bc867..6023d9c737 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -322,6 +322,7 @@ loadBuildConfig mproject config mresolver = do , projectExtraDeps = mempty , projectFlags = mempty , projectResolver = r + , projectExtraPackageDBs = [] } liftIO $ do S.writeFile dest' $ S.concat @@ -355,12 +356,15 @@ loadBuildConfig mproject config mresolver = do return $ mbpCompilerVersion mbp ResolverCompiler wantedCompiler -> return wantedCompiler + extraPackageDBs <- mapM parseRelAsAbsDir (projectExtraPackageDBs project) + return BuildConfig { bcConfig = config , bcResolver = projectResolver project , bcWantedCompiler = wantedCompiler , bcPackageEntries = projectPackages project , bcExtraDeps = projectExtraDeps project + , bcExtraPackageDBs = extraPackageDBs , bcStackYaml = stackYamlFP , bcFlags = projectFlags project , bcImplicitGlobal = isNothing mproject diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 270cff27b9..9b6b59f224 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -14,9 +14,9 @@ module Stack.Init ) where import Control.Exception (assert) -import Control.Exception.Enclosed (handleIO, catchAny) +import Control.Exception.Enclosed (catchAny, handleIO) import Control.Monad (liftM, when) -import Control.Monad.Catch (MonadMask, throwM, MonadThrow) +import Control.Monad.Catch (MonadMask, MonadThrow, throwM) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks) @@ -94,6 +94,7 @@ initProject currDir initOpts = do , projectExtraDeps = extraDeps , projectFlags = flags , projectResolver = r + , projectExtraPackageDBs = [] } pkgs = map toPkg cabalfps toPkg fp = PackageEntry @@ -250,7 +251,7 @@ getRecommendedSnapshots snapshots pref = do PrefNightly -> return $ namesNightly ++ namesLTS data InitOpts = InitOpts - { ioMethod :: !Method + { ioMethod :: !Method -- ^ Preferred snapshots , forceOverwrite :: Bool -- ^ Overwrite existing files diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index f8616589e6..0cceceb4d7 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -42,7 +42,6 @@ import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Either (partitionEithers) -import qualified Data.Foldable as F import Data.IORef import Data.Map (Map) import qualified Data.Map as Map @@ -81,18 +80,20 @@ ghcPkgDump :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride -> WhichCompiler - -> Maybe (Path Abs Dir) -- ^ if Nothing, use global + -> [Path Abs Dir] -- ^ if empty, use global -> Sink ByteString IO a -> m a -ghcPkgDump menv wc mpkgDb sink = do - F.mapM_ (createDatabase menv wc) mpkgDb -- TODO maybe use some retry logic instead? +ghcPkgDump menv wc mpkgDbs sink = do + case reverse mpkgDbs of + (pkgDb:_) -> (createDatabase menv wc) pkgDb -- TODO maybe use some retry logic instead? + _ -> return () a <- sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink return a where args = concat - [ case mpkgDb of - Nothing -> ["--global", "--no-user-package-db"] - Just pkgdb -> ["--user", "--no-user-package-db", "--package-db", toFilePath pkgdb] + [ case mpkgDbs of + [] -> ["--global", "--no-user-package-db"] + _ -> ["--user", "--no-user-package-db"] ++ concatMap (\pkgDb -> ["--package-db", toFilePath pkgDb]) mpkgDbs , ["dump", "--expand-pkgroot"] ] diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 67d49bec1c..01b0de1604 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} -- | Build-specific types. @@ -596,6 +596,7 @@ data BaseConfigOpts = BaseConfigOpts , bcoSnapInstallRoot :: !(Path Abs Dir) , bcoLocalInstallRoot :: !(Path Abs Dir) , bcoBuildOpts :: !BuildOpts + , bcoExtraDBs :: ![(Path Abs Dir)] } -- | Render a @BaseConfigOpts@ to an actual list of options @@ -618,8 +619,8 @@ configureOptsDirs :: BaseConfigOpts configureOptsDirs bco loc package = concat [ ["--user", "--package-db=clear", "--package-db=global"] , map (("--package-db=" ++) . toFilePath) $ case loc of - Snap -> [bcoSnapDB bco] - Local -> [bcoSnapDB bco, bcoLocalDB bco] + Snap -> bcoExtraDBs bco ++ [bcoSnapDB bco] + Local -> bcoExtraDBs bco ++ [bcoSnapDB bco] ++ [bcoLocalDB bco] , [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "lib")) , "--bindir=" ++ toFilePathNoTrailingSlash (installRoot bindirSuffix) , "--datadir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "share")) @@ -740,7 +741,7 @@ data PrecompiledCache = PrecompiledCache -- Use FilePath instead of Path Abs File for Binary instances { pcLibrary :: !(Maybe FilePath) -- ^ .conf file inside the package database - , pcExes :: ![FilePath] + , pcExes :: ![FilePath] -- ^ Full paths to executables } deriving (Show, Eq, Generic) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 1ca3a6369e..bce3a921ff 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -269,6 +269,8 @@ data BuildConfig = BuildConfig -- -- These dependencies will not be installed to a shared location, and -- will override packages provided by the resolver. + , bcExtraPackageDBs :: ![Path Abs Dir] + -- ^ Extra package databases , bcStackYaml :: !(Path Abs File) -- ^ Location of the stack.yaml file. -- @@ -404,15 +406,17 @@ data Project = Project -- ^ Per-package flag overrides , projectResolver :: !Resolver -- ^ How we resolve which dependencies to use + , projectExtraPackageDBs :: ![FilePath] } deriving Show instance ToJSON Project where toJSON p = object - [ "packages" .= projectPackages p - , "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p) - , "flags" .= projectFlags p - , "resolver" .= projectResolver p + [ "packages" .= projectPackages p + , "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p) + , "flags" .= projectFlags p + , "resolver" .= projectResolver p + , "extra-package-dbs" .= projectExtraPackageDBs p ] -- | How we resolve which dependencies to install given a set of packages. @@ -892,6 +896,12 @@ packageDatabaseLocal = do root <- installationRootLocal return $ root $(mkRelDir "pkgdb") +-- | Extra package databases +packageDatabaseExtra :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m [Path Abs Dir] +packageDatabaseExtra = do + bc <- asks getBuildConfig + return $ bcExtraPackageDBs bc + -- | Directory for holding flag cache information flagCacheLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) flagCacheLocal = do @@ -967,11 +977,13 @@ instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warning flags <- o ..:? "flags" ..!= mempty resolver <- jsonSubWarnings (o ..: "resolver") config <- parseConfigMonoidJSON o + extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] let project = Project { projectPackages = dirs , projectExtraDeps = extraDeps , projectFlags = flags , projectResolver = resolver + , projectExtraPackageDBs = extraPackageDBs } return $ ProjectAndConfigMonoid project config where diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 0f557401e4..92508d0b5b 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -249,6 +249,9 @@ instance Monoid InstallLocation where mappend _ Local = Local mappend Snap Snap = Snap +data InstalledPackageLocation = InstalledTo InstallLocation | ExtraGlobal + deriving (Show, Eq) + data FileCacheInfo = FileCacheInfo { fciModTime :: !ModTime , fciSize :: !Word64 diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index 5b49ddeb92..ba13b416f5 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -158,7 +158,7 @@ spec = do menv' <- getEnvOverride buildPlatform menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' icache <- newInstalledCache - ghcPkgDump menv Ghc Nothing + ghcPkgDump menv Ghc [] $ conduitDumpPackage =$ addProfiling icache =$ addHaddock icache @@ -168,7 +168,7 @@ spec = do menv' <- getEnvOverride buildPlatform menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' icache <- newInstalledCache - m <- runNoLoggingT $ ghcPkgDump menv Ghc Nothing + m <- runNoLoggingT $ ghcPkgDump menv Ghc [] $ conduitDumpPackage =$ addProfiling icache =$ addHaddock icache