Add a GitClone rule which fetches sources using git

Working copies are kept in the _cache/git/ directory.

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,56 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Clone a github repository into a cache directory.
+module Foliage.GitClone (
+  gitClone,
+  addGitCloneRule,
+)
+where
+
+import Control.Monad (unless)
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import Development.Shake.Rule
+import Foliage.Meta (GitHubRepo, GitHubRev)
+import GHC.Generics (Generic)
+
+data GitClone = GitClone {repo :: GitHubRepo, rev :: GitHubRev}
+  deriving (Eq, Generic, NFData)
+
+instance Show GitClone where
+  show GitClone{repo, rev} = "gitClone " <> show repo <> " " <> show rev
+
+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 -> GitHubRev -> Action FilePath
+gitClone repo rev = apply1 GitClone{repo, rev}
+
+-- | 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, rev} _old _mode = do
+    let path = cacheDir </> "git" </> show repo
+
+    alreadyCloned <- doesDirectoryExist path
+    unless alreadyCloned $ do
+      let url = "https://github.com/" <> show repo <> ".git"
+      command_ [] "git" ["clone", "--recursive", url, path]
+
+    command_ [Cwd path] "git" ["checkout", show rev]
+    command_ [Cwd path] "git" ["submodule", "update"]
+
+    return $ RunResult{runChanged = ChangedRecomputeDiff, runStore = "", runValue = path}

app/Foliage/Meta.hs

@@ -51,10 +51,16 @@ import Toml (TomlCodec, (.=))
 import Toml qualified
 
 newtype GitHubRepo = GitHubRepo {unGitHubRepo :: Text}
-  deriving (Show, Eq, Binary, Hashable, NFData) via Text
+  deriving (Eq, Binary, Hashable, NFData) via Text
+
+instance Show GitHubRepo where
+  show = T.unpack . unGitHubRepo
 
 newtype GitHubRev = GitHubRev {unGitHubRev :: Text}
-  deriving (Show, Eq, Binary, Hashable, NFData) via Text
+  deriving (Eq, Binary, Hashable, NFData) via Text
+
+instance Show GitHubRev where
+  show = T.unpack . unGitHubRev
 
 data PackageVersionSource
   = URISource

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 Foliage.Utils.GitHub (githubRepoTarballUrl)
@@ -70,8 +71,9 @@ addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run
             tarballPath <- fetchURL uri
             extractFromTarball tarballPath mSubdir srcDir
           GitHubSource repo rev mSubdir -> do
-            tarballPath <- fetchURL (githubRepoTarballUrl repo rev)
-            extractFromTarball tarballPath mSubdir srcDir
+            workDir <- gitClone repo rev
+            let packageDir = maybe workDir (workDir </>) mSubdir
+            copyDirectoryContents packageDir srcDir
 
         let patchesDir = inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "patches"
         hasPatches <- doesDirectoryExist patchesDir
@@ -117,16 +119,18 @@ addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run
           applyMSubdir = case mSubdir of Just s -> (</> s); _ -> id
           srcDir = applyMSubdir $ byPassSingleTopLevelDir tmpDir
 
-      cmd_
-        [ "cp"
-        , -- copy directories recursively
-          "--recursive"
-        , -- treat DEST as a normal file
-          "--no-target-directory"
-        , -- always follow symbolic links in SOURCE
-          "--dereference"
-        , -- SOURCE
-          srcDir
-        , -- DEST
-          outDir
-        ]
+      copyDirectoryContents srcDir outDir
+
+copyDirectoryContents :: FilePath -> FilePath -> Action ()
+copyDirectoryContents source destination =
+  cmd_
+    [ "cp"
+    , -- copy directories recursively
+      "--recursive"
+    , -- treat DEST as a normal file
+      "--no-target-directory"
+    , -- always follow symbolic links in SOURCE
+      "--dereference"
+    , source
+    , destination
+    ]

foliage.cabal

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

tests/Tests.hs

@@ -38,8 +38,6 @@ main = do
       , testCaseSteps "git submodules" $ \step ->
           inTemporaryDirectoryWithFixture "tests/fixtures/git-submodule" $ do
             step "Building repository"
-            -- TODO: build fails because of cabal-install not finding the
-            -- referenced files from the submodule
             callCommand "foliage build"
       , ---
         testCaseSteps "accepts --no-signatures" $ \step ->