Submodule support

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 Development.Shake hiding (doesDirectoryExist)
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import Development.Shake.Rule
+import Foliage.Meta (GitHubRepo, gitHubRepoToString)
+import GHC.Generics (Generic)
+import System.Directory (doesDirectoryExist)
+
+newtype GitClone = GitClone {repo :: GitHubRepo}
+  deriving (Eq, Generic)
+  deriving newtype (NFData)
+
+instance Show GitClone where
+  show GitClone{repo} = "gitClone " <> gitHubRepoToString 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" </> gitHubRepoToString repo
+
+    alreadyCloned <- liftIO $ doesDirectoryExist path
+    if alreadyCloned
+      then command_ [Cwd path] "git" ["fetch"]
+      else do
+        let url = "https://github.com/" <> gitHubRepoToString repo <> ".git"
+        command_ [] "git" ["clone", "--recursive", url, path]
+
+    return $ RunResult{runChanged = ChangedRecomputeDiff, runStore = "", runValue = path}

app/Foliage/Meta.hs

@@ -24,7 +24,9 @@ module Foliage.Meta (
   pattern URISource,
   pattern GitHubSource,
   GitHubRepo (..),
+  gitHubRepoToString,
   GitHubRev (..),
+  gitHubRevToString,
   UTCTime,
   latestRevisionNumber,
   packageVersionSourceToUri,
@@ -53,9 +55,17 @@ import Toml qualified
 newtype GitHubRepo = GitHubRepo {unGitHubRepo :: Text}
   deriving (Show, Eq, Binary, Hashable, NFData) via Text
 
+gitHubRepoToString :: GitHubRepo -> String
+gitHubRepoToString =
+  T.unpack . unGitHubRepo
+
 newtype GitHubRev = GitHubRev {unGitHubRev :: Text}
   deriving (Show, Eq, Binary, Hashable, NFData) via Text
 
+gitHubRevToString :: GitHubRev -> String
+gitHubRevToString =
+  T.unpack . unGitHubRev
+
 data PackageVersionSource
   = URISource
       { sourceURI :: URI

app/Foliage/PrepareSource.hs

@@ -15,9 +15,9 @@ 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)
 import GHC.Generics
 import Network.URI (URI (..))
 import System.Directory qualified as IO
@@ -70,8 +70,8 @@ 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
+            repoDir <- gitClone repo
+            copyGitWorktree repoDir rev mSubdir srcDir
 
         let patchesDir = inputDir </> unPackageName pkgName </> prettyShow pkgVersion </> "patches"
         hasPatches <- doesDirectoryExist patchesDir
@@ -117,16 +117,29 @@ 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
+
+-- | 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, gitHubRevToString rev]
+    command_ [Cwd tmpDir] "git" ["submodule", "update", "--init"]
+    let packageDir = maybe tmpDir (tmpDir </>) mSubdir
+    copyDirectoryContents packageDir outDir
+    command_ [Cwd repoDir] "git" ["worktree", "prune"]
+
+-- | Copy all contents from one directory to another.
+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
@@ -39,7 +40,6 @@ executable foliage
         Foliage.Time
         Foliage.UpdateCabalFile
         Foliage.Utils.Aeson
-        Foliage.Utils.GitHub
         Network.URI.Orphans
 
     build-depends:

tests/Tests.hs

@@ -35,6 +35,15 @@ main = do
                   assertFailure "entry for pkg-a-2.3.4.5 is missing"
                 Just entry -> do
                   entryTime entry @?= 1648534790
+      , ---
+        testCaseSteps "git submodules" $ \step ->
+          inTemporaryDirectoryWithFixture "tests/fixtures/git-submodule" $ do
+            step "Building repository"
+            callCommand "foliage build"
+
+            doesFileExist "_cache/git/cardano-scaling/foliage-test-with-submodule/README.md" @? "Missing working copy"
+            doesFileExist "_cache/foliage-test-with-submodule/1.0.0/README.md" @? "Missing packaged version"
+            doesFileExist "_cache/foliage-test-with-submodule/1.1.0/README.md" @? "Missing packaged version"
       , ---
         testCaseSteps "accepts --no-signatures" $ \step ->
           inTemporaryDirectoryWithFixture "tests/fixtures/simple" $ do

tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.0.0/meta.toml

@@ -0,0 +1,2 @@
+timestamp = 2023-11-03T17:35:22+00:00
+github = { repo = "cardano-scaling/foliage-test-with-submodule", rev = "db5874494ee5bac3fa8fee07d5806fcec27a2f4e" }

tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.1.0/meta.toml

@@ -0,0 +1,2 @@
+timestamp = 2023-11-03T15:53:59+00:00
+github = { repo = "cardano-scaling/foliage-test-with-submodule", rev = "1.1.0" }