feat(cabal-install): Store garbage collection

bla bla

- Create backlinks from storedir/gc-root to the dist directory at the same time as
  we write the plan.json file.
- TODO: add top level command that
  1. checks the gc-root directory for old roots and removes them (by checking whether the symlink resolves).
  2. traverse the dependency graph and do the garbage collection.

cabal-install/src/Distribution/Client/DistDirLayout.hs

@@ -126,6 +126,7 @@ data StoreDirLayout = StoreDirLayout
   , storePackageDBStack :: Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD
   , storeIncomingDirectory :: Compiler -> FilePath
   , storeIncomingLock :: Compiler -> UnitId -> FilePath
+  , storeGcRootsDirectory :: FilePath
   }
 
 -- TODO: move to another module, e.g. CabalDirLayout?
@@ -300,6 +301,10 @@ defaultStoreDirLayout storeRoot =
     storeIncomingLock compiler unitid =
       storeIncomingDirectory compiler </> prettyShow unitid <.> "lock"
 
+    storeGcRootsDirectory :: FilePath
+    storeGcRootsDirectory =
+      storeRoot </> "gc-roots"
+
 defaultCabalDirLayout :: IO CabalDirLayout
 defaultCabalDirLayout =
   mkCabalDirLayout Nothing Nothing

cabal-install/src/Distribution/Client/ProjectPlanOutput.hs

@@ -15,6 +15,9 @@ module Distribution.Client.ProjectPlanOutput
   , createPackageEnvironment
   , writePlanGhcEnvironment
   , argsEquivalentOfGhcEnvironmentFile
+
+    -- * Store garbage collection
+  , writeGcRoot
   ) where
 
 import Distribution.Client.DistDirLayout
@@ -36,6 +39,7 @@ import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps
 import qualified Distribution.Compat.Binary as Binary
 import Distribution.Compat.Graph (Graph, Node)
 import qualified Distribution.Compat.Graph as Graph
+import Distribution.Compiler (AbiTag (..), CompilerFlavor (..))
 import Distribution.InstalledPackageInfo (InstalledPackageInfo)
 import Distribution.Package
 import qualified Distribution.PackageDescription as PD
@@ -45,13 +49,28 @@ import Distribution.Simple.BuildPaths
   , exeExtension
   )
 import Distribution.Simple.Compiler
+  ( Compiler (compilerAbiTag)
+  , CompilerId (..)
+  , GlobalPackageDB
+  , PackageDB (..)
+  , PackageDBCWD
+  , PackageDBStack
+  , PackageDBStackCWD
+  , SpecificPackageDB
+  , UserPackageDB
+  , compilerFlavor
+  , compilerId
+  , compilerVersion
+  , showCompilerId
+  )
 import Distribution.Simple.GHC
   ( GhcEnvironmentFileEntry (..)
   , GhcImplInfo (supportsPkgEnvFiles)
   , getImplInfo
   , simpleGhcEnvironmentFile
   , writeGhcEnvironmentFile
   )
+import Distribution.Simple.Program.GHC (packageDbArgsDb)
 import Distribution.Simple.Utils
 import Distribution.System
 import Distribution.Types.Version
@@ -61,8 +80,10 @@ import Distribution.Utils.Path hiding
   ( (<.>)
   , (</>)
   )
+import Distribution.Utils.String (encodeStringUtf8)
 import Distribution.Verbosity
 
+import Distribution.Client.Compat.Directory (createFileLink)
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
@@ -71,10 +92,12 @@ import qualified Data.ByteString.Lazy as BS
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
+import Control.Exception (handleJust)
+import Data.Containers.ListUtils (nubOrd)
+import System.Directory (removeFile)
 import System.FilePath
 import System.IO
-
-import Distribution.Simple.Program.GHC (packageDbArgsDb)
+import System.IO.Error (isDoesNotExistError)
 
 -----------------------------------------------------------------------------
 -- Writing plan.json files
@@ -1016,3 +1039,50 @@ relativePackageDBPath relroot pkgdb =
     SpecificPackageDB path -> SpecificPackageDB relpath
       where
         relpath = makeRelative (normalise relroot) path
+
+-- | Establish backlinks for garbage collection of the store
+writeGcRoot
+  :: Verbosity
+  -> StoreDirLayout
+  -> DistDirLayout
+  -> ElaboratedSharedConfig
+  -> ElaboratedInstallPlan
+  -> IO ()
+writeGcRoot verbosity storeDirLayout distDirLayout elaboratedSharedConfig elaboratedInstallPlan = do
+  -- NOTE: this needs some thinking
+  -- We need to establish backlinks for the store so that we can collect garbage later on.
+  -- We have the whole build graph here so, to be pragmatic we are going to list all the
+  -- non-inplace units in the plan, irrespectively of whether they are direct or transitive
+  -- dependencies.
+  let refsUnitIds =
+        [ elabUnitId elab
+        | InstallPlan.Configured elab <- InstallPlan.toList elaboratedInstallPlan
+        , not (isInplaceBuildStyle (elabBuildStyle elab))
+        ]
+  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
+    storeGcRootsDir = storeGcRootsDirectory storeDirLayout
+    distDir = distDirectory distDirLayout
+    referencesFile = distProjectCacheFile distDirLayout "store-refs-" <> compilerTag
+    compiler = pkgConfigCompiler elaboratedSharedConfig
+    -- NOTE: It would be a good idea to expose this in StoreDirLayoyt
+    compilerTag = case compilerAbiTag compiler of
+      NoAbiTag -> prettyShow (compilerId compiler)
+      AbiTag tag -> prettyShow (compilerId compiler) <> "-" <> tag
+
+    -- 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

@@ -861,6 +861,9 @@ rebuildInstallPlan
           elaboratedPlan
           elaboratedShared
 
+        debug verbosity "Creating store garbage-collection root"
+        writeGcRoot verbosity cabalStoreDirLayout distDirLayout elaboratedShared elaboratedPlan
+
       -- Improve the elaborated install plan. The elaborated plan consists
       -- mostly of source packages (with full nix-style hashed ids). Where
       -- corresponding installed packages already exist in the store, replace