Skip to content

Commit ecc89f8

Browse files
vigoovigoo
committed
Ability to specify extra package DBs
1 parent 06a4b27 commit ecc89f8

11 files changed

Lines changed: 94 additions & 51 deletions

File tree

‎src/Stack/Build.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -122,12 +122,14 @@ mkBaseConfigOpts bopts = do
122122
localDBPath <- packageDatabaseLocal
123123
snapInstallRoot <- installationRootDeps
124124
localInstallRoot <- installationRootLocal
125+
packageExtraDBs <- packageDatabaseExtra
125126
return BaseConfigOpts
126127
{ bcoSnapDB = snapDBPath
127128
, bcoLocalDB = localDBPath
128129
, bcoSnapInstallRoot = snapInstallRoot
129130
, bcoLocalInstallRoot = localInstallRoot
130131
, bcoBuildOpts = bopts
132+
, bcoExtraDBs = packageExtraDBs
131133
}
132134

133135
-- | Provide a function for loading package information from the package index

‎src/Stack/Build/Execute.hs‎

Lines changed: 10 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -716,13 +716,16 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
716716
$ Set.toList
717717
$ addGlobalPackages deps eeGlobalPackages
718718
in
719-
"-clear-package-db"
720-
: "-global-package-db"
721-
: ("-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts))
722-
: ("-package-db=" ++ toFilePath (bcoLocalDB eeBaseConfigOpts))
723-
: "-hide-all-packages"
724-
: cabalPackageArg
725-
: map ("-package-id=" ++) depsMinusCabal
719+
( "-clear-package-db"
720+
: "-global-package-db"
721+
: map (("-package-db=" ++) . toFilePath) (bcoExtraDBs eeBaseConfigOpts)
722+
) ++
723+
( ("-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts))
724+
: ("-package-db=" ++ toFilePath (bcoLocalDB eeBaseConfigOpts))
725+
: "-hide-all-packages"
726+
: cabalPackageArg
727+
: map ("-package-id=" ++) depsMinusCabal
728+
)
726729
-- This branch is debatable. It adds access to the
727730
-- snapshot package database for Cabal. There are two
728731
-- possible objections:

‎src/Stack/Build/Installed.hs‎

Lines changed: 29 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE ConstraintKinds #-}
22
{-# LANGUAGE FlexibleContexts #-}
33
{-# LANGUAGE MultiParamTypeClasses #-}
4+
{-# LANGUAGE OverloadedStrings #-}
45
{-# LANGUAGE TemplateHaskell #-}
56
-- Determine which packages are already installed
67
module Stack.Build.Installed
@@ -69,6 +70,7 @@ getInstalled :: (M env m, PackageInstallInfo pii)
6970
getInstalled menv opts sourceMap = do
7071
snapDBPath <- packageDatabaseDeps
7172
localDBPath <- packageDatabaseLocal
73+
extraDBPaths <- packageDatabaseExtra
7274

7375
bconfig <- asks getBuildConfig
7476

@@ -78,12 +80,17 @@ getInstalled menv opts sourceMap = do
7880
else return Nothing
7981

8082
let loadDatabase' = loadDatabase menv opts mcache sourceMap
81-
(installedLibs0, globalInstalled) <- loadDatabase' Nothing []
82-
(installedLibs1, _snapInstalled) <-
83-
loadDatabase' (Just (Snap, snapDBPath)) installedLibs0
84-
(installedLibs2, localInstalled) <-
85-
loadDatabase' (Just (Local, localDBPath)) installedLibs1
86-
let installedLibs = M.fromList $ map lhPair installedLibs2
83+
84+
(installedLibs0, globalInstalled) <- loadDatabase' [] Nothing []
85+
(installedLibs1, _extraInstalled) <-
86+
(snd <$> (foldM (\(prevDBs, lhs') pkgdb -> do
87+
lhs'' <- loadDatabase' prevDBs (Just (ExtraGlobal, pkgdb)) (fst lhs')
88+
return (prevDBs ++ [pkgdb], lhs'')) ([], (installedLibs0, globalInstalled)) extraDBPaths))
89+
(installedLibs2, _snapInstalled) <-
90+
loadDatabase' extraDBPaths (Just (InstalledTo Snap, snapDBPath)) installedLibs1
91+
(installedLibs3, localInstalled) <-
92+
loadDatabase' extraDBPaths (Just (InstalledTo Local, localDBPath)) installedLibs2
93+
let installedLibs = M.fromList $ map lhPair installedLibs3
8794

8895
case mcache of
8996
Nothing -> return ()
@@ -126,13 +133,15 @@ loadDatabase :: (M env m, PackageInstallInfo pii)
126133
-> GetInstalledOpts
127134
-> Maybe InstalledCache -- ^ if Just, profiling or haddock is required
128135
-> Map PackageName pii -- ^ to determine which installed things we should include
129-
-> Maybe (InstallLocation, Path Abs Dir) -- ^ package database, Nothing for global
136+
-> [Path Abs Dir] -- ^ extra package databases this database depends on
137+
-> Maybe (InstalledPackageLocation, Path Abs Dir) -- ^ package database, Nothing for global
130138
-> [LoadHelper] -- ^ from parent databases
131139
-> m ([LoadHelper], [DumpPackage () ()])
132-
loadDatabase menv opts mcache sourceMap mdb lhs0 = do
140+
loadDatabase menv opts mcache sourceMap extraDBs mdb lhs0 = do
133141
wc <- getWhichCompiler
134-
(lhs1, dps) <- ghcPkgDump menv wc (fmap snd mdb)
135-
$ conduitDumpPackage =$ sink
142+
(lhs1, dps) <- ghcPkgDump menv wc (extraDBs ++ (fmap snd (maybeToList mdb)))
143+
$ conduitDumpPackage =$ sink
144+
136145
let lhs = pruneDeps
137146
id
138147
lhId
@@ -168,7 +177,7 @@ isAllowed :: PackageInstallInfo pii
168177
=> GetInstalledOpts
169178
-> Maybe InstalledCache
170179
-> Map PackageName pii
171-
-> Maybe InstallLocation
180+
-> Maybe InstalledPackageLocation
172181
-> DumpPackage Bool Bool
173182
-> Maybe LoadHelper
174183
isAllowed opts mcache sourceMap mloc dp
@@ -188,17 +197,23 @@ isAllowed opts mcache sourceMap mloc dp
188197
if name `HashSet.member` wiredInPackages
189198
then []
190199
else dpDepends dp
191-
, lhPair = (name, (version, fromMaybe Snap mloc, Library ident gid))
200+
, lhPair = (name, (version, toPackageLocation mloc, Library ident gid))
192201
}
193202
| otherwise = Nothing
194203
where
204+
toPackageLocation :: Maybe InstalledPackageLocation -> InstallLocation
205+
toPackageLocation Nothing = Snap
206+
toPackageLocation (Just ExtraGlobal) = Snap
207+
toPackageLocation (Just (InstalledTo loc)) = loc
208+
195209
toInclude =
196210
case Map.lookup name sourceMap of
197211
Nothing ->
198212
case mloc of
199213
-- The sourceMap has nothing to say about this global
200214
-- package, so we can use it
201215
Nothing -> True
216+
Just ExtraGlobal -> True
202217
-- For non-global packages, don't include unknown packages.
203218
-- See:
204219
-- https://github.com/commercialhaskell/stack/issues/292
@@ -210,8 +225,8 @@ isAllowed opts mcache sourceMap mloc dp
210225

211226
-- Ensure that the installed location matches where the sourceMap says it
212227
-- should be installed
213-
checkLocation Snap = mloc /= Just Local -- we can allow either global or snap
214-
checkLocation Local = mloc == Just Local
228+
checkLocation Snap = mloc /= Just (InstalledTo Local) -- we can allow either global or snap
229+
checkLocation Local = mloc == Just (InstalledTo Local) || mloc == Just ExtraGlobal -- 'locally' installed snapshot packages can come from extra dbs
215230

216231
gid = dpGhcPkgId dp
217232
ident@(PackageIdentifier name version) = dpPackageIdent dp

‎src/Stack/Build/Source.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -80,7 +80,6 @@ loadSourceMap needTargets bopts = do
8080
bconfig <- asks getBuildConfig
8181
rawLocals <- getLocalPackageViews
8282
(mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets bopts
83-
8483
menv <- getMinimalEnvOverride
8584
caches <- getPackageCaches menv
8685
let latestVersion = Map.fromListWith max $ map toTuple $ Map.keys caches
@@ -183,16 +182,18 @@ parseTargetsFromBuildOpts needTargets bopts = do
183182
(bcExtraDeps bconfig)
184183
(catMaybes $ Map.keys $ boptsFlags bopts)
185184

186-
(cliExtraDeps, targets) <-
185+
let extraDeps' = flagExtraDeps <> bcExtraDeps bconfig
186+
187+
(_cliExtraDeps, targets) <-
187188
parseTargets
188189
needTargets
189190
(bcImplicitGlobal bconfig)
190191
snapshot
191-
(flagExtraDeps <> bcExtraDeps bconfig)
192+
extraDeps'
192193
(fst <$> rawLocals)
193194
workingDir
194195
(boptsTargets bopts)
195-
return (mbp0, cliExtraDeps <> flagExtraDeps, targets)
196+
return (mbp0, extraDeps', targets)
196197

197198
-- | For every package in the snapshot which is referenced by a flag, give the
198199
-- user a warning and then add it to extra-deps.

‎src/Stack/Config.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -322,6 +322,7 @@ loadBuildConfig mproject config mresolver = do
322322
, projectExtraDeps = mempty
323323
, projectFlags = mempty
324324
, projectResolver = r
325+
, projectExtraPackageDBs = []
325326
}
326327
liftIO $ do
327328
S.writeFile dest' $ S.concat
@@ -355,12 +356,15 @@ loadBuildConfig mproject config mresolver = do
355356
return $ mbpCompilerVersion mbp
356357
ResolverCompiler wantedCompiler -> return wantedCompiler
357358

359+
extraPackageDBs <- mapM parseRelAsAbsDir (projectExtraPackageDBs project)
360+
358361
return BuildConfig
359362
{ bcConfig = config
360363
, bcResolver = projectResolver project
361364
, bcWantedCompiler = wantedCompiler
362365
, bcPackageEntries = projectPackages project
363366
, bcExtraDeps = projectExtraDeps project
367+
, bcExtraPackageDBs = extraPackageDBs
364368
, bcStackYaml = stackYamlFP
365369
, bcFlags = projectFlags project
366370
, bcImplicitGlobal = isNothing mproject

‎src/Stack/Init.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -14,9 +14,9 @@ module Stack.Init
1414
) where
1515

1616
import Control.Exception (assert)
17-
import Control.Exception.Enclosed (handleIO, catchAny)
17+
import Control.Exception.Enclosed (catchAny, handleIO)
1818
import Control.Monad (liftM, when)
19-
import Control.Monad.Catch (MonadMask, throwM, MonadThrow)
19+
import Control.Monad.Catch (MonadMask, MonadThrow, throwM)
2020
import Control.Monad.IO.Class
2121
import Control.Monad.Logger
2222
import Control.Monad.Reader (MonadReader, asks)
@@ -94,6 +94,7 @@ initProject currDir initOpts = do
9494
, projectExtraDeps = extraDeps
9595
, projectFlags = flags
9696
, projectResolver = r
97+
, projectExtraPackageDBs = []
9798
}
9899
pkgs = map toPkg cabalfps
99100
toPkg fp = PackageEntry
@@ -250,7 +251,7 @@ getRecommendedSnapshots snapshots pref = do
250251
PrefNightly -> return $ namesNightly ++ namesLTS
251252

252253
data InitOpts = InitOpts
253-
{ ioMethod :: !Method
254+
{ ioMethod :: !Method
254255
-- ^ Preferred snapshots
255256
, forceOverwrite :: Bool
256257
-- ^ Overwrite existing files

‎src/Stack/PackageDump.hs‎

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,6 @@ import Data.Conduit
4242
import qualified Data.Conduit.Binary as CB
4343
import qualified Data.Conduit.List as CL
4444
import Data.Either (partitionEithers)
45-
import qualified Data.Foldable as F
4645
import Data.IORef
4746
import Data.Map (Map)
4847
import qualified Data.Map as Map
@@ -81,18 +80,20 @@ ghcPkgDump
8180
:: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
8281
=> EnvOverride
8382
-> WhichCompiler
84-
-> Maybe (Path Abs Dir) -- ^ if Nothing, use global
83+
-> [Path Abs Dir] -- ^ if empty, use global
8584
-> Sink ByteString IO a
8685
-> m a
87-
ghcPkgDump menv wc mpkgDb sink = do
88-
F.mapM_ (createDatabase menv wc) mpkgDb -- TODO maybe use some retry logic instead?
86+
ghcPkgDump menv wc mpkgDbs sink = do
87+
case reverse mpkgDbs of
88+
(pkgDb:_) -> (createDatabase menv wc) pkgDb -- TODO maybe use some retry logic instead?
89+
_ -> return ()
8990
a <- sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink
9091
return a
9192
where
9293
args = concat
93-
[ case mpkgDb of
94-
Nothing -> ["--global", "--no-user-package-db"]
95-
Just pkgdb -> ["--user", "--no-user-package-db", "--package-db", toFilePath pkgdb]
94+
[ case mpkgDbs of
95+
[] -> ["--global", "--no-user-package-db"]
96+
_ -> ["--user", "--no-user-package-db"] ++ concatMap (\pkgDb -> ["--package-db", toFilePath pkgDb]) mpkgDbs
9697
, ["dump", "--expand-pkgroot"]
9798
]
9899

‎src/Stack/Types/Build.hs‎

Lines changed: 11 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,11 @@
1-
{-# LANGUAGE TemplateHaskell #-}
2-
{-# LANGUAGE FlexibleInstances #-}
3-
{-# LANGUAGE DataKinds #-}
4-
{-# LANGUAGE OverloadedStrings #-}
5-
{-# LANGUAGE DeriveGeneric #-}
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveDataTypeable #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE FlexibleInstances #-}
65
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7-
{-# LANGUAGE DeriveDataTypeable #-}
8-
{-# LANGUAGE ViewPatterns #-}
6+
{-# LANGUAGE OverloadedStrings #-}
7+
{-# LANGUAGE TemplateHaskell #-}
8+
{-# LANGUAGE ViewPatterns #-}
99

1010
-- | Build-specific types.
1111

@@ -596,6 +596,7 @@ data BaseConfigOpts = BaseConfigOpts
596596
, bcoSnapInstallRoot :: !(Path Abs Dir)
597597
, bcoLocalInstallRoot :: !(Path Abs Dir)
598598
, bcoBuildOpts :: !BuildOpts
599+
, bcoExtraDBs :: ![(Path Abs Dir)]
599600
}
600601

601602
-- | Render a @BaseConfigOpts@ to an actual list of options
@@ -618,8 +619,8 @@ configureOptsDirs :: BaseConfigOpts
618619
configureOptsDirs bco loc package = concat
619620
[ ["--user", "--package-db=clear", "--package-db=global"]
620621
, map (("--package-db=" ++) . toFilePath) $ case loc of
621-
Snap -> [bcoSnapDB bco]
622-
Local -> [bcoSnapDB bco, bcoLocalDB bco]
622+
Snap -> bcoExtraDBs bco ++ [bcoSnapDB bco]
623+
Local -> bcoExtraDBs bco ++ [bcoSnapDB bco] ++ [bcoLocalDB bco]
623624
, [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "lib"))
624625
, "--bindir=" ++ toFilePathNoTrailingSlash (installRoot </> bindirSuffix)
625626
, "--datadir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "share"))
@@ -740,7 +741,7 @@ data PrecompiledCache = PrecompiledCache
740741
-- Use FilePath instead of Path Abs File for Binary instances
741742
{ pcLibrary :: !(Maybe FilePath)
742743
-- ^ .conf file inside the package database
743-
, pcExes :: ![FilePath]
744+
, pcExes :: ![FilePath]
744745
-- ^ Full paths to executables
745746
}
746747
deriving (Show, Eq, Generic)

‎src/Stack/Types/Config.hs‎

Lines changed: 16 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -269,6 +269,8 @@ data BuildConfig = BuildConfig
269269
--
270270
-- These dependencies will not be installed to a shared location, and
271271
-- will override packages provided by the resolver.
272+
, bcExtraPackageDBs :: ![Path Abs Dir]
273+
-- ^ Extra package databases
272274
, bcStackYaml :: !(Path Abs File)
273275
-- ^ Location of the stack.yaml file.
274276
--
@@ -404,15 +406,17 @@ data Project = Project
404406
-- ^ Per-package flag overrides
405407
, projectResolver :: !Resolver
406408
-- ^ How we resolve which dependencies to use
409+
, projectExtraPackageDBs :: ![FilePath]
407410
}
408411
deriving Show
409412

410413
instance ToJSON Project where
411414
toJSON p = object
412-
[ "packages" .= projectPackages p
413-
, "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p)
414-
, "flags" .= projectFlags p
415-
, "resolver" .= projectResolver p
415+
[ "packages" .= projectPackages p
416+
, "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p)
417+
, "flags" .= projectFlags p
418+
, "resolver" .= projectResolver p
419+
, "extra-package-dbs" .= projectExtraPackageDBs p
416420
]
417421

418422
-- | How we resolve which dependencies to install given a set of packages.
@@ -892,6 +896,12 @@ packageDatabaseLocal = do
892896
root <- installationRootLocal
893897
return $ root </> $(mkRelDir "pkgdb")
894898

899+
-- | Extra package databases
900+
packageDatabaseExtra :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m [Path Abs Dir]
901+
packageDatabaseExtra = do
902+
bc <- asks getBuildConfig
903+
return $ bcExtraPackageDBs bc
904+
895905
-- | Directory for holding flag cache information
896906
flagCacheLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
897907
flagCacheLocal = do
@@ -967,11 +977,13 @@ instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warning
967977
flags <- o ..:? "flags" ..!= mempty
968978
resolver <- jsonSubWarnings (o ..: "resolver")
969979
config <- parseConfigMonoidJSON o
980+
extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []
970981
let project = Project
971982
{ projectPackages = dirs
972983
, projectExtraDeps = extraDeps
973984
, projectFlags = flags
974985
, projectResolver = resolver
986+
, projectExtraPackageDBs = extraPackageDBs
975987
}
976988
return $ ProjectAndConfigMonoid project config
977989
where

‎src/Stack/Types/Package.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -249,6 +249,9 @@ instance Monoid InstallLocation where
249249
mappend _ Local = Local
250250
mappend Snap Snap = Snap
251251

252+
data InstalledPackageLocation = InstalledTo InstallLocation | ExtraGlobal
253+
deriving (Show, Eq)
254+
252255
data FileCacheInfo = FileCacheInfo
253256
{ fciModTime :: !ModTime
254257
, fciSize :: !Word64

0 commit comments

Comments
 (0)