diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index cf6e8ff514f..e2b5435fbb3 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -125,7 +125,7 @@ data StoreDirLayout = StoreDirLayout , storePackageDBStack :: Compiler -> [Maybe PackageDB] -> PackageDBStack , storeIncomingDirectory :: Compiler -> FilePath , storeIncomingLock :: Compiler -> UnitId -> FilePath - , storeGcDirectory :: FilePath + , storeGcRootsDirectory :: FilePath } -- TODO: move to another module, e.g. CabalDirLayout? @@ -300,8 +300,8 @@ defaultStoreDirLayout storeRoot = storeIncomingLock compiler unitid = storeIncomingDirectory compiler prettyShow unitid <.> "lock" - storeGcDirectory :: FilePath - storeGcDirectory = + storeGcRootsDirectory :: FilePath + storeGcRootsDirectory = storeRoot "gc-roots" defaultCabalDirLayout :: IO CabalDirLayout diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index 02054a73d5f..b4869211cb5 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -69,6 +69,7 @@ import Distribution.Simple.GHC , simpleGhcEnvironmentFile , writeGhcEnvironmentFile ) +import Distribution.Simple.Program.GHC (packageDbArgsDb) import Distribution.Simple.Utils import Distribution.System import Distribution.Types.Version @@ -78,9 +79,11 @@ import Distribution.Utils.Path hiding ( (<.>) , () ) +import Distribution.Utils.String (encodeStringUtf8) import Distribution.Verbosity import Distribution.Client.Compat.Prelude +import Distribution.Client.Compat.Directory (createFileLink) import Prelude () import qualified Data.ByteString.Builder as BB @@ -90,9 +93,11 @@ import qualified Data.Set as Set import System.FilePath import System.IO +import System.Directory (removeFile) +import Control.Exception (handleJust) +import System.IO.Error (isDoesNotExistError) +import Data.Containers.ListUtils (nubOrd) -import Distribution.Simple.Program.GHC (packageDbArgsDb) -import System.Directory (createDirectoryLink) ----------------------------------------------------------------------------- -- Writing plan.json files @@ -1035,14 +1040,47 @@ relativePackageDBPath relroot pkgdb = where relpath = makeRelative (normalise relroot) path --- | Establish backlinks for the store garbage collection -writeGcRoot - :: Verbosity - -> StoreDirLayout - -> DistDirLayout - -> IO () -writeGcRoot verbosity storeDirLayout distDirLayout = do - createDirectoryIfMissingVerbose verbosity True gcRootsDir - createDirectoryLink (distDirectory distDirLayout) gcRootsDir +-- | Establish backlinks for garbage collection of the store +writeGcRoot :: + Verbosity -> + StoreDirLayout -> + DistDirLayout -> + ElaboratedInstallPlan -> + IO () +writeGcRoot verbosity storeDirLayout distDirLayout elaboratedInstallPlan = do + -- NOTE: this needs some thinking + -- We need to establish backlinks for the store so that we can collect garbage later on. + -- The maintained references are: + -- - select inplace packages + -- - take their direct dependencies + -- - select the non-inplace packages + -- In other words, the non-inplace packages which are direct depedencies of inplace packages. + -- Transitive dependencies are already covered by the direct dependencies. + let refsUnitIds = [ elabUnitId elab_dep + | InstallPlan.Configured elab <- InstallPlan.toList elaboratedInstallPlan + , isInplaceBuildStyle (elabBuildStyle elab) + , InstallPlan.Configured elab_dep <- InstallPlan.directDeps elaboratedInstallPlan (elabUnitId elab) + , not (isInplaceBuildStyle (elabBuildStyle elab_dep)) + ] + writeFile referencesFile $ unlines $ map unUnitId $ nubOrd refsUnitIds + + -- Write the gc root + createDirectoryIfMissingVerbose verbosity True storeGcRootsDir + + -- To avoid collision we name the link with the hash of the dist directory. + let gcRootPath = storeGcRootsDir showHashValue (hashValue (encodePath distDir)) + + handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) mempty $ + removeFile gcRootPath + + createFileLink distDir gcRootPath where - gcRootsDir = storeGcDirectory storeDirLayout + storeGcRootsDir = storeGcRootsDirectory storeDirLayout + distDir = distDirectory distDirLayout + referencesFile = distProjectCacheFile distDirLayout "gc-refs" + + -- NOTE: A FilePath should never represented as a String as we should never + -- have to do this. Nevetheless we do not need this to be stable as changes + -- will only mean a new root is created in place of the old one. Two roots + -- pointing to the same directory should never be a problem. + encodePath = BS.pack . encodeStringUtf8 diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 6df6a6c0ef0..fce7c591ddb 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -850,7 +850,7 @@ rebuildInstallPlan elaboratedShared debug verbosity "Creating store garbage-collection root" - writeGcRoot verbosity cabalStoreDirLayout distDirLayout + writeGcRoot verbosity cabalStoreDirLayout distDirLayout elaboratedPlan -- Improve the elaborated install plan. The elaborated plan consists -- mostly of source packages (with full nix-style hashed ids). Where