Re-add custom rule for GitClone and use git worktree to prepare source

This re-uses the git repository in the _cache/git/<user>/<repo>
directory, but uses a temporary directory to get the worktree for a
given rev to prepare the per-package directory in _cache/<package>.

Author: ch1bo

app/Foliage/CmdBuild.hs

@@ -23,6 +23,7 @@ import Distribution.Package
 import Distribution.Pretty (prettyShow)
 import Distribution.Version
 import Foliage.FetchURL (addFetchURLRule)
+import Foliage.GitClone (addGitCloneRule)
 import Foliage.HackageSecurity hiding (ToJSON, toJSON)
 import Foliage.Meta
 import Foliage.Meta.Aeson ()
@@ -42,6 +43,7 @@ cmdBuild buildOptions = do
   shake opts $
     do
       addFetchURLRule cacheDir
+      addGitCloneRule cacheDir
       addPrepareSourceRule (buildOptsInputDir buildOptions) cacheDir
       addPrepareSdistRule outputDirRoot
       phony "buildAction" (buildAction buildOptions)

app/Foliage/GitClone.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Clone a github repository into a cache directory.
+module Foliage.GitClone (
+  gitClone,
+  addGitCloneRule,
+)
+where
+
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import Development.Shake.Rule
+import Foliage.Meta (GitHubRepo)
+import GHC.Generics (Generic)
+
+newtype GitClone = GitClone {repo :: GitHubRepo}
+  deriving (Eq, Generic)
+  deriving newtype (NFData)
+
+instance Show GitClone where
+  show GitClone{repo} = "gitClone " <> show repo
+
+instance Hashable GitClone
+
+instance Binary GitClone
+
+type instance RuleResult GitClone = FilePath
+
+-- | Clone given repo at given revision into the cache directory and return the working copy path.
+gitClone :: GitHubRepo -> Action FilePath
+gitClone repo = apply1 GitClone{repo}
+
+-- | Set up the 'GitClone' rule with a cache directory.
+addGitCloneRule
+  :: FilePath
+  -- ^ Cache directory
+  -> Rules ()
+addGitCloneRule cacheDir = addBuiltinRule noLint noIdentity run
+ where
+  run :: BuiltinRun GitClone FilePath
+  run GitClone{repo} _old _mode = do
+    let path = cacheDir </> "git" </> show repo
+
+    alreadyCloned <- doesDirectoryExist path
+    if alreadyCloned
+      then command_ [Cwd path] "git" ["fetch"]
+      else do
+        let url = "https://github.com/" <> show repo <> ".git"
+        command_ [] "git" ["clone", "--recursive", url, path]
+
+    return $ RunResult{runChanged = ChangedRecomputeDiff, runStore = "", runValue = path}

app/Foliage/PrepareSource.hs

@@ -15,6 +15,7 @@ import Distribution.Pretty (prettyShow)
 import Distribution.Types.PackageId
 import Distribution.Types.PackageName (unPackageName)
 import Foliage.FetchURL (fetchURL)
+import Foliage.GitClone (gitClone)
 import Foliage.Meta
 import Foliage.UpdateCabalFile (rewritePackageVersion)
 import GHC.Generics
@@ -69,9 +70,8 @@ addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run
             tarballPath <- fetchURL uri
             extractFromTarball tarballPath mSubdir srcDir
           GitHubSource repo rev mSubdir -> do
-            workingCopy <- gitCheckout cacheDir repo rev
-            let packageDir = maybe workingCopy (workingCopy </>) mSubdir
-            copyDirectoryContents packageDir srcDir
+            repoDir <- gitClone repo
+            copyGitWorktree repoDir rev mSubdir srcDir
 
         let patchesDir = inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "patches"
         hasPatches <- doesDirectoryExist patchesDir
@@ -119,20 +119,16 @@ addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run
 
       copyDirectoryContents srcDir outDir
 
-gitCheckout :: FilePath -> GitHubRepo -> GitHubRev -> Action FilePath
-gitCheckout cacheDir repo rev = do
-  alreadyCloned <- doesDirectoryExist path
-  if alreadyCloned
-    then command_ [Cwd path] "git" ["fetch"]
-    else command_ [] "git" ["clone", "--recursive", url, path]
-  command_ [Cwd path] "git" ["checkout", show rev]
-  command_ [Cwd path] "git" ["submodule", "update"]
-  pure path
- where
-  path = cacheDir </> "git" </> show repo
-
-  url = "https://github.com/" <> show repo <> ".git"
+-- | Copy package source from a git repository using 'git worktree'.
+copyGitWorktree :: FilePath -> GitHubRev -> Maybe FilePath -> FilePath -> Action ()
+copyGitWorktree repoDir rev mSubdir outDir = do
+  withTempDir $ \tmpDir -> do
+    command_ [Cwd repoDir] "git" ["worktree", "add", tmpDir, show rev]
+    command_ [Cwd tmpDir] "git" ["submodule", "update", "--init"]
+    let packageDir = maybe tmpDir (tmpDir </>) mSubdir
+    copyDirectoryContents packageDir outDir
 
+-- | Copy all contents from one directory to another.
 copyDirectoryContents :: FilePath -> FilePath -> Action ()
 copyDirectoryContents source destination =
   cmd_

foliage.cabal

@@ -27,6 +27,7 @@ executable foliage
         Foliage.CmdCreateKeys
         Foliage.CmdImportIndex
         Foliage.FetchURL
+        Foliage.GitClone
         Foliage.HackageSecurity
         Foliage.Meta
         Foliage.Meta.Aeson