Merge pull request #6868 from phadej/issue-6819

Issue 6819: Write active-repositories to freeze files

Cabal/Distribution/Utils/Generic.hs

@@ -77,6 +77,11 @@ module Distribution.Utils.Generic (
         unsnoc,
         unsnocNE,
 
+        -- * Triples
+        fstOf3,
+        sndOf3,
+        trdOf3,
+
         -- * FilePath stuff
         isAbsoluteOnAnyPlatform,
         isRelativeOnAnyPlatform,
@@ -90,10 +95,9 @@ import Distribution.Utils.String
 import Data.Bits ((.&.), (.|.), shiftL)
 import Data.List
     ( isInfixOf )
-import qualified Data.ByteString.Lazy as BS
 import qualified Data.Set as Set
-
 import qualified Data.ByteString as SBS
+import qualified Data.ByteString.Lazy as LBS
 
 import System.Directory
     ( removeFile, renameFile )
@@ -154,14 +158,14 @@ withFileContents name action =
 -- On windows it is not possible to delete a file that is open by a process.
 -- This case will give an IO exception but the atomic property is not affected.
 --
-writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
+writeFileAtomic :: FilePath -> LBS.ByteString -> IO ()
 writeFileAtomic targetPath content = do
   let (targetDir, targetFile) = splitFileName targetPath
   Exception.bracketOnError
     (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
     (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
     (\(tmpPath, handle) -> do
-        BS.hPut handle content
+        LBS.hPut handle content
         hClose handle
         renameFile tmpPath targetPath)
 
@@ -179,8 +183,8 @@ fromUTF8BS = decodeStringUtf8 . SBS.unpack
 
 -- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's
 --
-fromUTF8LBS :: BS.ByteString -> String
-fromUTF8LBS = decodeStringUtf8 . BS.unpack
+fromUTF8LBS :: LBS.ByteString -> String
+fromUTF8LBS = decodeStringUtf8 . LBS.unpack
 
 -- | Encode 'String' to to UTF8-encoded 'SBS.ByteString'
 --
@@ -192,8 +196,8 @@ toUTF8BS = SBS.pack . encodeStringUtf8
 
 -- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's
 --
-toUTF8LBS :: String -> BS.ByteString
-toUTF8LBS = BS.pack . encodeStringUtf8
+toUTF8LBS :: String -> LBS.ByteString
+toUTF8LBS = LBS.pack . encodeStringUtf8
 
 -- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not.
 validateUTF8 :: SBS.ByteString -> Maybe Int
@@ -246,7 +250,7 @@ ignoreBOM string            = string
 -- Reads lazily using ordinary 'readFile'.
 --
 readUTF8File :: FilePath -> IO String
-readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> BS.readFile f
+readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f
 
 -- | Reads a UTF8 encoded text file as a Unicode String
 --
@@ -255,14 +259,14 @@ readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> BS.readFile f
 withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a
 withUTF8FileContents name action =
   withBinaryFile name ReadMode
-    (\hnd -> BS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS)
+    (\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS)
 
 -- | Writes a Unicode String as a UTF8 encoded text file.
 --
 -- Uses 'writeFileAtomic', so provides the same guarantees.
 --
 writeUTF8File :: FilePath -> String -> IO ()
-writeUTF8File path = writeFileAtomic path . BS.pack . encodeStringUtf8
+writeUTF8File path = writeFileAtomic path . toUTF8LBS
 
 -- | Fix different systems silly line ending conventions
 normaliseLineEndings :: String -> String
@@ -514,6 +518,22 @@ unsnocNE (x:|xs) = go x xs where
     go y []     = ([], y)
     go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w)
 
+-------------------------------------------------------------------------------
+-- Triples
+-------------------------------------------------------------------------------
+
+-- | @since 3.4.0.0
+fstOf3 :: (a,b,c) -> a
+fstOf3 (a,_,_) = a
+
+-- | @since 3.4.0.0
+sndOf3 :: (a,b,c) -> b
+sndOf3 (_,b,_) = b
+
+-- | @since 3.4.0.0
+trdOf3 :: (a,b,c) -> c
+trdOf3 (_,_,c) = c
+
 -- ------------------------------------------------------------
 -- * FilePath stuff
 -- ------------------------------------------------------------

cabal-install/Distribution/Client/CmdFreeze.hs

@@ -17,7 +17,7 @@ import Distribution.Client.ProjectPlanning
 import Distribution.Client.ProjectConfig
          ( ProjectConfig(..), ProjectConfigShared(..)
          , writeProjectLocalFreezeConfig )
-import Distribution.Client.IndexUtils (TotalIndexState)
+import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos)
 import Distribution.Client.Targets
          ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) )
 import Distribution.Solver.Types.PackageConstraint
@@ -117,13 +117,13 @@ freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do
       localPackages
     } <- establishProjectBaseContext verbosity cliConfig OtherCommand
 
-    (_, elaboratedPlan, _, totalIndexState) <-
+    (_, elaboratedPlan, _, totalIndexState, activeRepos) <-
       rebuildInstallPlan verbosity
                          distDirLayout cabalDirLayout
                          projectConfig
                          localPackages
 
-    let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState
+    let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos
     writeProjectLocalFreezeConfig distDirLayout freezeConfig
     notice verbosity $
       "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"
@@ -138,12 +138,17 @@ freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do
 -- | Given the install plan, produce a config value with constraints that
 -- freezes the versions of packages used in the plan.
 --
-projectFreezeConfig :: ElaboratedInstallPlan -> TotalIndexState -> ProjectConfig
-projectFreezeConfig elaboratedPlan totalIndexState = mempty
+projectFreezeConfig
+    :: ElaboratedInstallPlan
+    -> TotalIndexState
+    -> ActiveRepos
+    -> ProjectConfig
+projectFreezeConfig elaboratedPlan totalIndexState activeRepos = mempty
     { projectConfigShared = mempty
         { projectConfigConstraints =
           concat (Map.elems (projectFreezeConstraints elaboratedPlan))
-        , projectConfigIndexState = Flag totalIndexState
+        , projectConfigIndexState  = Flag totalIndexState
+        , projectConfigActiveRepos = Flag activeRepos
         }
     }
 

cabal-install/Distribution/Client/Freeze.hs

@@ -50,11 +50,10 @@ import Distribution.Simple.Program
 import Distribution.Simple.Setup
          ( fromFlag, fromFlagOrDefault, flagToMaybe )
 import Distribution.Simple.Utils
-         ( die', notice, debug, writeFileAtomic )
+         ( die', notice, debug, writeFileAtomic, toUTF8LBS)
 import Distribution.System
          ( Platform )
 
-import qualified Data.ByteString.Lazy.Char8 as BS.Char8
 import Distribution.Version
          ( thisVersion )
 
@@ -256,7 +255,7 @@ freezePackages verbosity globalFlags pkgs = do
             UserConstraint (UserQualified UserQualToplevel (packageName pkgId))
                            (PackagePropertyVersion $ thisVersion (packageVersion pkgId))
     createPkgEnv config = mempty { pkgEnvSavedConfig = config }
-    showPkgEnv = BS.Char8.pack . showPackageEnvironment
+    showPkgEnv = toUTF8LBS . showPackageEnvironment
 
 
 formatPkgs :: Package pkg => [pkg] -> [String]

cabal-install/Distribution/Client/Get.hs

@@ -81,7 +81,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
       activeRepos :: Maybe ActiveRepos
       activeRepos = flagToMaybe $ getActiveRepos getFlags
 
-  (sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos
+  (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos
 
   pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
                    (fromFlag $ globalWorldFile globalFlags)

cabal-install/Distribution/Client/IndexUtils.hs

@@ -107,6 +107,7 @@ import System.IO
 import System.IO.Unsafe (unsafeInterleaveIO)
 import System.IO.Error (isDoesNotExistError)
 import Distribution.Compat.Directory (listDirectory)
+import Distribution.Utils.Generic (fstOf3)
 
 import qualified Codec.Compression.GZip as GZip
 
@@ -194,7 +195,7 @@ filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})
 -- This is a higher level wrapper used internally in cabal-install.
 getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
 getSourcePackages verbosity repoCtxt =
-    fst <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing
+    fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing
 
 -- | Variant of 'getSourcePackages' which allows getting the source
 -- packages at a particular 'IndexState'.
@@ -210,7 +211,7 @@ getSourcePackagesAtIndexState
     -> RepoContext
     -> Maybe TotalIndexState
     -> Maybe ActiveRepos
-    -> IO (SourcePackageDb, TotalIndexState)
+    -> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
 getSourcePackagesAtIndexState verbosity repoCtxt _ _
   | null (repoContextRepos repoCtxt) = do
       -- In the test suite, we routinely don't have any remote package
@@ -221,7 +222,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt _ _
       return (SourcePackageDb {
         packageIndex       = mempty,
         packagePreferences = mempty
-      }, headTotalIndexState)
+      }, headTotalIndexState, ActiveRepos [])
 getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
   let describeState IndexStateHead        = "most recent state"
       describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
@@ -299,6 +300,12 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
     Right x  -> return x
     Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss)
 
+  let activeRepos' :: ActiveRepos
+      activeRepos' = ActiveRepos
+          [ ActiveRepo (rdRepoName rd) strategy
+          | (rd, strategy) <- pkgss'
+          ]
+
   let totalIndexState :: TotalIndexState
       totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList
           [ (n, IndexStateTime ts)
@@ -329,7 +336,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
   return (SourcePackageDb {
     packageIndex       = pkgs,
     packagePreferences = prefs
-  }, totalIndexState)
+  }, totalIndexState, activeRepos')
 
 -- auxiliary data used in getSourcePackagesAtIndexState
 data RepoData = RepoData

cabal-install/Distribution/Client/Install.hs

@@ -261,9 +261,9 @@ makeInstallContext verbosity
 
     let idxState = flagToMaybe (installIndexState installFlags)
 
-    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
-    (sourcePkgDb, _)  <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing
-    pkgConfigDb       <- readPkgConfigDb      verbosity progdb
+    installedPkgIndex   <- getInstalledPackages verbosity comp packageDBs progdb
+    (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing
+    pkgConfigDb         <- readPkgConfigDb      verbosity progdb
 
     checkConfigExFlags verbosity installedPkgIndex
                        (packageIndex sourcePkgDb) configExFlags

cabal-install/Distribution/Client/ProjectOrchestration.hs

@@ -300,7 +300,7 @@ withInstallPlan
     -- everything in the project. This is independent of any specific targets
     -- the user has asked for.
     --
-    (elaboratedPlan, _, elaboratedShared, _) <-
+    (elaboratedPlan, _, elaboratedShared, _, _) <-
       rebuildInstallPlan verbosity
                          distDirLayout cabalDirLayout
                          projectConfig
@@ -325,7 +325,7 @@ runProjectPreBuildPhase
     -- everything in the project. This is independent of any specific targets
     -- the user has asked for.
     --
-    (elaboratedPlan, _, elaboratedShared, _) <-
+    (elaboratedPlan, _, elaboratedShared, _, _) <-
       rebuildInstallPlan verbosity
                          distDirLayout cabalDirLayout
                          projectConfig

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -392,8 +392,10 @@ rebuildInstallPlan :: Verbosity
                    -> IO ( ElaboratedInstallPlan  -- with store packages
                          , ElaboratedInstallPlan  -- with source packages
                          , ElaboratedSharedConfig
-                         , IndexUtils.TotalIndexState )
-                      -- ^ @(improvedPlan, elaboratedPlan, _, _)@
+                         , IndexUtils.TotalIndexState
+                         , IndexUtils.ActiveRepos
+                         )
+                      -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@
 rebuildInstallPlan verbosity
                    distDirLayout@DistDirLayout {
                      distProjectRootDirectory,
@@ -413,14 +415,14 @@ rebuildInstallPlan verbosity
                    (projectConfigMonitored, localPackages, progsearchpath) $ do
 
       -- And so is the elaborated plan that the improved plan based on
-      (elaboratedPlan, elaboratedShared, totalIndexState) <-
+      (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <-
         rerunIfChanged verbosity fileMonitorElaboratedPlan
                        (projectConfigMonitored, localPackages,
                         progsearchpath) $ do
 
           compilerEtc   <- phaseConfigureCompiler projectConfig
           _             <- phaseConfigurePrograms projectConfig compilerEtc
-          (solverPlan, pkgConfigDB, totalIndexState)
+          (solverPlan, pkgConfigDB, totalIndexState, activeRepos)
                         <- phaseRunSolver         projectConfig
                                                   compilerEtc
                                                   localPackages
@@ -431,14 +433,14 @@ rebuildInstallPlan verbosity
                                                    localPackages
 
           phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
-          return (elaboratedPlan, elaboratedShared, totalIndexState)
+          return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)
 
       -- The improved plan changes each time we install something, whereas
       -- the underlying elaborated plan only changes when input config
       -- changes, so it's worth caching them separately.
       improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared
 
-      return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState)
+      return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)
 
   where
     fileMonitorCompiler       = newFileMonitorInCacheDir "compiler"
@@ -543,7 +545,7 @@ rebuildInstallPlan verbosity
         :: ProjectConfig
         -> (Compiler, Platform, ProgramDb)
         -> [PackageSpecifier UnresolvedSourcePackage]
-        -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState)
+        -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)
     phaseRunSolver projectConfig@ProjectConfig {
                      projectConfigShared,
                      projectConfigBuildOnly
@@ -558,9 +560,9 @@ rebuildInstallPlan verbosity
           installedPkgIndex <- getInstalledPackages verbosity
                                                     compiler progdb platform
                                                     corePackageDbs
-          (sourcePkgDb, tis)<- getSourcePackages verbosity withRepoCtx
-                                 (solverSettingIndexState solverSettings)
-                                 (solverSettingActiveRepos solverSettings)
+          (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx
+              (solverSettingIndexState solverSettings)
+              (solverSettingActiveRepos solverSettings)
           pkgConfigDB       <- getPkgConfigDb verbosity progdb
 
           --TODO: [code cleanup] it'd be better if the Compiler contained the
@@ -578,7 +580,7 @@ rebuildInstallPlan verbosity
               planPackages verbosity compiler platform solver solverSettings
                            installedPkgIndex sourcePkgDb pkgConfigDB
                            localPackages localPackagesEnabledStanzas
-            return (plan, pkgConfigDB, tis)
+            return (plan, pkgConfigDB, tis, ar)
       where
         corePackageDbs = [GlobalPackageDB]
         withRepoCtx    = projectConfigWithSolverRepoContext verbosity
@@ -760,7 +762,7 @@ getSourcePackages
     -> (forall a. (RepoContext -> IO a) -> IO a)
     -> Maybe IndexUtils.TotalIndexState
     -> Maybe IndexUtils.ActiveRepos
-    -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState)
+    -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)
 getSourcePackages verbosity withRepoCtx idxState activeRepos = do
     (sourcePkgDbWithTIS, repos) <-
       liftIO $

cabal-install/tests/IntegrationTests2.hs

@@ -1505,7 +1505,7 @@ planProject testdir cliConfig = do
        localPackages,
        _buildSettings) <- configureProject testdir cliConfig
 
-    (elaboratedPlan, _, elaboratedShared, _) <-
+    (elaboratedPlan, _, elaboratedShared, _, _) <-
       rebuildInstallPlan verbosity
                          distDirLayout cabalDirLayout
                          projectConfig