Extra package database support

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

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:

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,17 +196,23 @@ 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 ->
                 case mloc of
                     -- 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

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

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

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

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"]
         ]
 

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)

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

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

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