Skip to content

Commit 1148ecf

Browse files
phadejphadej
authored
Merge pull request #6868 from phadej/issue-6819
Issue 6819: Write active-repositories to freeze files
2 parents ee11888 + e267103 commit 1148ecf

File tree

9 files changed

+76
-43
lines changed

9 files changed

+76
-43
lines changed

‎Cabal/Distribution/Utils/Generic.hs

Lines changed: 31 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -77,6 +77,11 @@ module Distribution.Utils.Generic (
7777
unsnoc,
7878
unsnocNE,
7979

80+
-- * Triples
81+
fstOf3,
82+
sndOf3,
83+
trdOf3,
84+
8085
-- * FilePath stuff
8186
isAbsoluteOnAnyPlatform,
8287
isRelativeOnAnyPlatform,
@@ -90,10 +95,9 @@ import Distribution.Utils.String
9095
import Data.Bits ((.&.), (.|.), shiftL)
9196
import Data.List
9297
( isInfixOf )
93-
import qualified Data.ByteString.Lazy as BS
9498
import qualified Data.Set as Set
95-
9699
import qualified Data.ByteString as SBS
100+
import qualified Data.ByteString.Lazy as LBS
97101

98102
import System.Directory
99103
( removeFile, renameFile )
@@ -154,14 +158,14 @@ withFileContents name action =
154158
-- On windows it is not possible to delete a file that is open by a process.
155159
-- This case will give an IO exception but the atomic property is not affected.
156160
--
157-
writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
161+
writeFileAtomic :: FilePath -> LBS.ByteString -> IO ()
158162
writeFileAtomic targetPath content = do
159163
let (targetDir, targetFile) = splitFileName targetPath
160164
Exception.bracketOnError
161165
(openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
162166
(\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
163167
(\(tmpPath, handle) -> do
164-
BS.hPut handle content
168+
LBS.hPut handle content
165169
hClose handle
166170
renameFile tmpPath targetPath)
167171

@@ -179,8 +183,8 @@ fromUTF8BS = decodeStringUtf8 . SBS.unpack
179183

180184
-- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's
181185
--
182-
fromUTF8LBS :: BS.ByteString -> String
183-
fromUTF8LBS = decodeStringUtf8 . BS.unpack
186+
fromUTF8LBS :: LBS.ByteString -> String
187+
fromUTF8LBS = decodeStringUtf8 . LBS.unpack
184188

185189
-- | Encode 'String' to to UTF8-encoded 'SBS.ByteString'
186190
--
@@ -192,8 +196,8 @@ toUTF8BS = SBS.pack . encodeStringUtf8
192196

193197
-- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's
194198
--
195-
toUTF8LBS :: String -> BS.ByteString
196-
toUTF8LBS = BS.pack . encodeStringUtf8
199+
toUTF8LBS :: String -> LBS.ByteString
200+
toUTF8LBS = LBS.pack . encodeStringUtf8
197201

198202
-- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not.
199203
validateUTF8 :: SBS.ByteString -> Maybe Int
@@ -246,7 +250,7 @@ ignoreBOM string = string
246250
-- Reads lazily using ordinary 'readFile'.
247251
--
248252
readUTF8File :: FilePath -> IO String
249-
readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> BS.readFile f
253+
readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f
250254

251255
-- | Reads a UTF8 encoded text file as a Unicode String
252256
--
@@ -255,14 +259,14 @@ readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> BS.readFile f
255259
withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a
256260
withUTF8FileContents name action =
257261
withBinaryFile name ReadMode
258-
(\hnd -> BS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS)
262+
(\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS)
259263

260264
-- | Writes a Unicode String as a UTF8 encoded text file.
261265
--
262266
-- Uses 'writeFileAtomic', so provides the same guarantees.
263267
--
264268
writeUTF8File :: FilePath -> String -> IO ()
265-
writeUTF8File path = writeFileAtomic path . BS.pack . encodeStringUtf8
269+
writeUTF8File path = writeFileAtomic path . toUTF8LBS
266270

267271
-- | Fix different systems silly line ending conventions
268272
normaliseLineEndings :: String -> String
@@ -514,6 +518,22 @@ unsnocNE (x:|xs) = go x xs where
514518
go y [] = ([], y)
515519
go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w)
516520

521+
-------------------------------------------------------------------------------
522+
-- Triples
523+
-------------------------------------------------------------------------------
524+
525+
-- | @since 3.4.0.0
526+
fstOf3 :: (a,b,c) -> a
527+
fstOf3 (a,_,_) = a
528+
529+
-- | @since 3.4.0.0
530+
sndOf3 :: (a,b,c) -> b
531+
sndOf3 (_,b,_) = b
532+
533+
-- | @since 3.4.0.0
534+
trdOf3 :: (a,b,c) -> c
535+
trdOf3 (_,_,c) = c
536+
517537
-- ------------------------------------------------------------
518538
-- * FilePath stuff
519539
-- ------------------------------------------------------------

‎cabal-install/Distribution/Client/CmdFreeze.hs

Lines changed: 11 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ import Distribution.Client.ProjectPlanning
1717
import Distribution.Client.ProjectConfig
1818
( ProjectConfig(..), ProjectConfigShared(..)
1919
, writeProjectLocalFreezeConfig )
20-
import Distribution.Client.IndexUtils (TotalIndexState)
20+
import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos)
2121
import Distribution.Client.Targets
2222
( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) )
2323
import Distribution.Solver.Types.PackageConstraint
@@ -117,13 +117,13 @@ freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do
117117
localPackages
118118
} <- establishProjectBaseContext verbosity cliConfig OtherCommand
119119

120-
(_, elaboratedPlan, _, totalIndexState) <-
120+
(_, elaboratedPlan, _, totalIndexState, activeRepos) <-
121121
rebuildInstallPlan verbosity
122122
distDirLayout cabalDirLayout
123123
projectConfig
124124
localPackages
125125

126-
let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState
126+
let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos
127127
writeProjectLocalFreezeConfig distDirLayout freezeConfig
128128
notice verbosity $
129129
"Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"
@@ -138,12 +138,17 @@ freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do
138138
-- | Given the install plan, produce a config value with constraints that
139139
-- freezes the versions of packages used in the plan.
140140
--
141-
projectFreezeConfig :: ElaboratedInstallPlan -> TotalIndexState -> ProjectConfig
142-
projectFreezeConfig elaboratedPlan totalIndexState = mempty
141+
projectFreezeConfig
142+
:: ElaboratedInstallPlan
143+
-> TotalIndexState
144+
-> ActiveRepos
145+
-> ProjectConfig
146+
projectFreezeConfig elaboratedPlan totalIndexState activeRepos = mempty
143147
{ projectConfigShared = mempty
144148
{ projectConfigConstraints =
145149
concat (Map.elems (projectFreezeConstraints elaboratedPlan))
146-
, projectConfigIndexState = Flag totalIndexState
150+
, projectConfigIndexState = Flag totalIndexState
151+
, projectConfigActiveRepos = Flag activeRepos
147152
}
148153
}
149154

‎cabal-install/Distribution/Client/Freeze.hs

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -50,11 +50,10 @@ import Distribution.Simple.Program
5050
import Distribution.Simple.Setup
5151
( fromFlag, fromFlagOrDefault, flagToMaybe )
5252
import Distribution.Simple.Utils
53-
( die', notice, debug, writeFileAtomic )
53+
( die', notice, debug, writeFileAtomic, toUTF8LBS)
5454
import Distribution.System
5555
( Platform )
5656

57-
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
5857
import Distribution.Version
5958
( thisVersion )
6059

@@ -256,7 +255,7 @@ freezePackages verbosity globalFlags pkgs = do
256255
UserConstraint (UserQualified UserQualToplevel (packageName pkgId))
257256
(PackagePropertyVersion $ thisVersion (packageVersion pkgId))
258257
createPkgEnv config = mempty { pkgEnvSavedConfig = config }
259-
showPkgEnv = BS.Char8.pack . showPackageEnvironment
258+
showPkgEnv = toUTF8LBS . showPackageEnvironment
260259

261260

262261
formatPkgs :: Package pkg => [pkg] -> [String]

‎cabal-install/Distribution/Client/Get.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -81,7 +81,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
8181
activeRepos :: Maybe ActiveRepos
8282
activeRepos = flagToMaybe $ getActiveRepos getFlags
8383

84-
(sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos
84+
(sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos
8585

8686
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
8787
(fromFlag $ globalWorldFile globalFlags)

‎cabal-install/Distribution/Client/IndexUtils.hs

Lines changed: 11 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -107,6 +107,7 @@ import System.IO
107107
import System.IO.Unsafe (unsafeInterleaveIO)
108108
import System.IO.Error (isDoesNotExistError)
109109
import Distribution.Compat.Directory (listDirectory)
110+
import Distribution.Utils.Generic (fstOf3)
110111

111112
import qualified Codec.Compression.GZip as GZip
112113

@@ -194,7 +195,7 @@ filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})
194195
-- This is a higher level wrapper used internally in cabal-install.
195196
getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
196197
getSourcePackages verbosity repoCtxt =
197-
fst <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing
198+
fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing
198199

199200
-- | Variant of 'getSourcePackages' which allows getting the source
200201
-- packages at a particular 'IndexState'.
@@ -210,7 +211,7 @@ getSourcePackagesAtIndexState
210211
-> RepoContext
211212
-> Maybe TotalIndexState
212213
-> Maybe ActiveRepos
213-
-> IO (SourcePackageDb, TotalIndexState)
214+
-> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
214215
getSourcePackagesAtIndexState verbosity repoCtxt _ _
215216
| null (repoContextRepos repoCtxt) = do
216217
-- In the test suite, we routinely don't have any remote package
@@ -221,7 +222,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt _ _
221222
return (SourcePackageDb {
222223
packageIndex = mempty,
223224
packagePreferences = mempty
224-
}, headTotalIndexState)
225+
}, headTotalIndexState, ActiveRepos [])
225226
getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
226227
let describeState IndexStateHead = "most recent state"
227228
describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
@@ -299,6 +300,12 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
299300
Right x -> return x
300301
Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss)
301302

303+
let activeRepos' :: ActiveRepos
304+
activeRepos' = ActiveRepos
305+
[ ActiveRepo (rdRepoName rd) strategy
306+
| (rd, strategy) <- pkgss'
307+
]
308+
302309
let totalIndexState :: TotalIndexState
303310
totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList
304311
[ (n, IndexStateTime ts)
@@ -329,7 +336,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
329336
return (SourcePackageDb {
330337
packageIndex = pkgs,
331338
packagePreferences = prefs
332-
}, totalIndexState)
339+
}, totalIndexState, activeRepos')
333340

334341
-- auxiliary data used in getSourcePackagesAtIndexState
335342
data RepoData = RepoData

‎cabal-install/Distribution/Client/Install.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -261,9 +261,9 @@ makeInstallContext verbosity
261261

262262
let idxState = flagToMaybe (installIndexState installFlags)
263263

264-
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
265-
(sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing
266-
pkgConfigDb <- readPkgConfigDb verbosity progdb
264+
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
265+
(sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing
266+
pkgConfigDb <- readPkgConfigDb verbosity progdb
267267

268268
checkConfigExFlags verbosity installedPkgIndex
269269
(packageIndex sourcePkgDb) configExFlags

‎cabal-install/Distribution/Client/ProjectOrchestration.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -300,7 +300,7 @@ withInstallPlan
300300
-- everything in the project. This is independent of any specific targets
301301
-- the user has asked for.
302302
--
303-
(elaboratedPlan, _, elaboratedShared, _) <-
303+
(elaboratedPlan, _, elaboratedShared, _, _) <-
304304
rebuildInstallPlan verbosity
305305
distDirLayout cabalDirLayout
306306
projectConfig
@@ -325,7 +325,7 @@ runProjectPreBuildPhase
325325
-- everything in the project. This is independent of any specific targets
326326
-- the user has asked for.
327327
--
328-
(elaboratedPlan, _, elaboratedShared, _) <-
328+
(elaboratedPlan, _, elaboratedShared, _, _) <-
329329
rebuildInstallPlan verbosity
330330
distDirLayout cabalDirLayout
331331
projectConfig

‎cabal-install/Distribution/Client/ProjectPlanning.hs

Lines changed: 14 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -392,8 +392,10 @@ rebuildInstallPlan :: Verbosity
392392
-> IO ( ElaboratedInstallPlan -- with store packages
393393
, ElaboratedInstallPlan -- with source packages
394394
, ElaboratedSharedConfig
395-
, IndexUtils.TotalIndexState )
396-
-- ^ @(improvedPlan, elaboratedPlan, _, _)@
395+
, IndexUtils.TotalIndexState
396+
, IndexUtils.ActiveRepos
397+
)
398+
-- ^ @(improvedPlan, elaboratedPlan, _, _, _)@
397399
rebuildInstallPlan verbosity
398400
distDirLayout@DistDirLayout {
399401
distProjectRootDirectory,
@@ -413,14 +415,14 @@ rebuildInstallPlan verbosity
413415
(projectConfigMonitored, localPackages, progsearchpath) $ do
414416

415417
-- And so is the elaborated plan that the improved plan based on
416-
(elaboratedPlan, elaboratedShared, totalIndexState) <-
418+
(elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <-
417419
rerunIfChanged verbosity fileMonitorElaboratedPlan
418420
(projectConfigMonitored, localPackages,
419421
progsearchpath) $ do
420422

421423
compilerEtc <- phaseConfigureCompiler projectConfig
422424
_ <- phaseConfigurePrograms projectConfig compilerEtc
423-
(solverPlan, pkgConfigDB, totalIndexState)
425+
(solverPlan, pkgConfigDB, totalIndexState, activeRepos)
424426
<- phaseRunSolver projectConfig
425427
compilerEtc
426428
localPackages
@@ -431,14 +433,14 @@ rebuildInstallPlan verbosity
431433
localPackages
432434

433435
phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
434-
return (elaboratedPlan, elaboratedShared, totalIndexState)
436+
return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)
435437

436438
-- The improved plan changes each time we install something, whereas
437439
-- the underlying elaborated plan only changes when input config
438440
-- changes, so it's worth caching them separately.
439441
improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared
440442

441-
return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState)
443+
return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)
442444

443445
where
444446
fileMonitorCompiler = newFileMonitorInCacheDir "compiler"
@@ -543,7 +545,7 @@ rebuildInstallPlan verbosity
543545
:: ProjectConfig
544546
-> (Compiler, Platform, ProgramDb)
545547
-> [PackageSpecifier UnresolvedSourcePackage]
546-
-> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState)
548+
-> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)
547549
phaseRunSolver projectConfig@ProjectConfig {
548550
projectConfigShared,
549551
projectConfigBuildOnly
@@ -558,9 +560,9 @@ rebuildInstallPlan verbosity
558560
installedPkgIndex <- getInstalledPackages verbosity
559561
compiler progdb platform
560562
corePackageDbs
561-
(sourcePkgDb, tis)<- getSourcePackages verbosity withRepoCtx
562-
(solverSettingIndexState solverSettings)
563-
(solverSettingActiveRepos solverSettings)
563+
(sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx
564+
(solverSettingIndexState solverSettings)
565+
(solverSettingActiveRepos solverSettings)
564566
pkgConfigDB <- getPkgConfigDb verbosity progdb
565567

566568
--TODO: [code cleanup] it'd be better if the Compiler contained the
@@ -578,7 +580,7 @@ rebuildInstallPlan verbosity
578580
planPackages verbosity compiler platform solver solverSettings
579581
installedPkgIndex sourcePkgDb pkgConfigDB
580582
localPackages localPackagesEnabledStanzas
581-
return (plan, pkgConfigDB, tis)
583+
return (plan, pkgConfigDB, tis, ar)
582584
where
583585
corePackageDbs = [GlobalPackageDB]
584586
withRepoCtx = projectConfigWithSolverRepoContext verbosity
@@ -760,7 +762,7 @@ getSourcePackages
760762
-> (forall a. (RepoContext -> IO a) -> IO a)
761763
-> Maybe IndexUtils.TotalIndexState
762764
-> Maybe IndexUtils.ActiveRepos
763-
-> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState)
765+
-> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)
764766
getSourcePackages verbosity withRepoCtx idxState activeRepos = do
765767
(sourcePkgDbWithTIS, repos) <-
766768
liftIO $

‎cabal-install/tests/IntegrationTests2.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1505,7 +1505,7 @@ planProject testdir cliConfig = do
15051505
localPackages,
15061506
_buildSettings) <- configureProject testdir cliConfig
15071507

1508-
(elaboratedPlan, _, elaboratedShared, _) <-
1508+
(elaboratedPlan, _, elaboratedShared, _, _) <-
15091509
rebuildInstallPlan verbosity
15101510
distDirLayout cabalDirLayout
15111511
projectConfig

0 commit comments

Comments
 (0)