WIP

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

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

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