From 2943666a0cbb4ef576f7cdab20348b6173c27449 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 3 Nov 2023 17:12:26 +0100 Subject: [PATCH 1/8] Write a test case using a test fixture repository This test fails now because the tarball fetching of sources does not include files from the submodule (but the fixture references a file as a data-file) --- tests/Tests.hs | 6 ++++++ .../_sources/foliage-test-with-submodule/1.0.0/meta.toml | 2 ++ 2 files changed, 8 insertions(+) create mode 100644 tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.0.0/meta.toml diff --git a/tests/Tests.hs b/tests/Tests.hs index 20119ea..d1a2abe 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -35,6 +35,12 @@ 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" + -- TODO: build fails because of cabal-install not finding the + -- referenced files from the submodule + callCommand "foliage build" , --- testCaseSteps "accepts --no-signatures" $ \step -> inTemporaryDirectoryWithFixture "tests/fixtures/simple" $ do diff --git a/tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.0.0/meta.toml b/tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.0.0/meta.toml new file mode 100644 index 0000000..7442c0a --- /dev/null +++ b/tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.0.0/meta.toml @@ -0,0 +1,2 @@ +timestamp = 2023-11-03T15:53:59+00:00 +github = { repo = "cardano-scaling/foliage-test-with-submodule", rev = "db5874494ee5bac3fa8fee07d5806fcec27a2f4e" } From ba799aec4b723545eee3c2d1f040d0308d42a784 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 3 Nov 2023 18:11:39 +0100 Subject: [PATCH 2/8] Add a GitClone rule which fetches sources using git Working copies are kept in the _cache/git/ directory. --- app/Foliage/CmdBuild.hs | 2 ++ app/Foliage/GitClone.hs | 56 ++++++++++++++++++++++++++++++++++++ app/Foliage/Meta.hs | 10 +++++-- app/Foliage/PrepareSource.hs | 34 ++++++++++++---------- foliage.cabal | 1 + tests/Tests.hs | 2 -- 6 files changed, 86 insertions(+), 19 deletions(-) create mode 100644 app/Foliage/GitClone.hs diff --git a/app/Foliage/CmdBuild.hs b/app/Foliage/CmdBuild.hs index c44b4ad..51e4118 100644 --- a/app/Foliage/CmdBuild.hs +++ b/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) diff --git a/app/Foliage/GitClone.hs b/app/Foliage/GitClone.hs new file mode 100644 index 0000000..0dca693 --- /dev/null +++ b/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} diff --git a/app/Foliage/Meta.hs b/app/Foliage/Meta.hs index 71d7942..abd11af 100644 --- a/app/Foliage/Meta.hs +++ b/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 diff --git a/app/Foliage/PrepareSource.hs b/app/Foliage/PrepareSource.hs index 2c6762e..cace51b 100644 --- a/app/Foliage/PrepareSource.hs +++ b/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 + ] diff --git a/foliage.cabal b/foliage.cabal index d817eea..11218ef 100644 --- a/foliage.cabal +++ b/foliage.cabal @@ -27,6 +27,7 @@ executable foliage Foliage.CmdCreateKeys Foliage.CmdImportIndex Foliage.FetchURL + Foliage.GitClone Foliage.HackageSecurity Foliage.Meta Foliage.Meta.Aeson diff --git a/tests/Tests.hs b/tests/Tests.hs index d1a2abe..6733455 100644 --- a/tests/Tests.hs +++ b/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 -> From 77d2454b946af4e5c4802511902756bbed0fa170 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 3 Nov 2023 18:32:27 +0100 Subject: [PATCH 3/8] Remove unused githubRepoTarballUrl helper --- app/Foliage/PrepareSource.hs | 1 - app/Foliage/Utils/GitHub.hs | 17 ----------------- foliage.cabal | 1 - 3 files changed, 19 deletions(-) delete mode 100644 app/Foliage/Utils/GitHub.hs diff --git a/app/Foliage/PrepareSource.hs b/app/Foliage/PrepareSource.hs index cace51b..4d4ae02 100644 --- a/app/Foliage/PrepareSource.hs +++ b/app/Foliage/PrepareSource.hs @@ -18,7 +18,6 @@ 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 diff --git a/app/Foliage/Utils/GitHub.hs b/app/Foliage/Utils/GitHub.hs deleted file mode 100644 index b3eb1e1..0000000 --- a/app/Foliage/Utils/GitHub.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Foliage.Utils.GitHub ( - githubRepoTarballUrl, -) -where - -import Data.Text qualified as T -import Foliage.Meta (GitHubRepo (unGitHubRepo), GitHubRev (unGitHubRev)) -import Network.URI (URI (..), URIAuth (..), nullURI, nullURIAuth) -import System.FilePath (()) - -githubRepoTarballUrl :: GitHubRepo -> GitHubRev -> URI -githubRepoTarballUrl repo rev = - nullURI - { uriScheme = "https:" - , uriAuthority = Just nullURIAuth{uriRegName = "github.com"} - , uriPath = "/" T.unpack (unGitHubRepo repo) "tarball" T.unpack (unGitHubRev rev) - } diff --git a/foliage.cabal b/foliage.cabal index 11218ef..9d5d66a 100644 --- a/foliage.cabal +++ b/foliage.cabal @@ -40,7 +40,6 @@ executable foliage Foliage.Time Foliage.UpdateCabalFile Foliage.Utils.Aeson - Foliage.Utils.GitHub Network.URI.Orphans build-depends: From 7cd94c971b97543c65344208c0fcf0c1a2ebbcfc Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 3 Nov 2023 18:41:44 +0100 Subject: [PATCH 4/8] Fetch already cloned working copies and add test fixture This adds another version of the same package fetched via git. The same working copy from _cache/git// is re-used in both PrepareSource steps (which hopefully do not conflict) and copied onto individual _cache// directories. The second package version in the git-submodule fixture _sources also uses a tag name as rev to highlight this is possible as well. --- app/Foliage/GitClone.hs | 9 +++++---- tests/Tests.hs | 3 ++- .../_sources/foliage-test-with-submodule/1.0.0/meta.toml | 2 +- .../_sources/foliage-test-with-submodule/1.1.0/meta.toml | 2 ++ 4 files changed, 10 insertions(+), 6 deletions(-) create mode 100644 tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.1.0/meta.toml diff --git a/app/Foliage/GitClone.hs b/app/Foliage/GitClone.hs index 0dca693..c780cb9 100644 --- a/app/Foliage/GitClone.hs +++ b/app/Foliage/GitClone.hs @@ -10,7 +10,6 @@ module Foliage.GitClone ( ) where -import Control.Monad (unless) import Development.Shake import Development.Shake.Classes import Development.Shake.FilePath @@ -46,9 +45,11 @@ addGitCloneRule cacheDir = addBuiltinRule noLint noIdentity run 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] + if alreadyCloned + then command_ [Cwd path] "git" ["fetch"] + else 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"] diff --git a/tests/Tests.hs b/tests/Tests.hs index 6733455..d1639a3 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -35,7 +35,8 @@ main = do assertFailure "entry for pkg-a-2.3.4.5 is missing" Just entry -> do entryTime entry @?= 1648534790 - , testCaseSteps "git submodules" $ \step -> + , --- + testCaseSteps "git submodules" $ \step -> inTemporaryDirectoryWithFixture "tests/fixtures/git-submodule" $ do step "Building repository" callCommand "foliage build" diff --git a/tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.0.0/meta.toml b/tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.0.0/meta.toml index 7442c0a..44a1b20 100644 --- a/tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.0.0/meta.toml +++ b/tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.0.0/meta.toml @@ -1,2 +1,2 @@ -timestamp = 2023-11-03T15:53:59+00:00 +timestamp = 2023-11-03T17:35:22+00:00 github = { repo = "cardano-scaling/foliage-test-with-submodule", rev = "db5874494ee5bac3fa8fee07d5806fcec27a2f4e" } diff --git a/tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.1.0/meta.toml b/tests/fixtures/git-submodule/_sources/foliage-test-with-submodule/1.1.0/meta.toml new file mode 100644 index 0000000..f748b83 --- /dev/null +++ b/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" } From cae3ce4ca05a6715d27219ebe59898a58c269221 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 6 Nov 2023 18:18:40 +0100 Subject: [PATCH 5/8] Make gitCheckout just an Action, no additional rule This avoids some boiler plate and works just the same. --- app/Foliage/CmdBuild.hs | 2 -- app/Foliage/GitClone.hs | 57 ------------------------------------ app/Foliage/PrepareSource.hs | 19 ++++++++++-- foliage.cabal | 1 - tests/Tests.hs | 4 +++ 5 files changed, 20 insertions(+), 63 deletions(-) delete mode 100644 app/Foliage/GitClone.hs diff --git a/app/Foliage/CmdBuild.hs b/app/Foliage/CmdBuild.hs index 51e4118..c44b4ad 100644 --- a/app/Foliage/CmdBuild.hs +++ b/app/Foliage/CmdBuild.hs @@ -23,7 +23,6 @@ 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 () @@ -43,7 +42,6 @@ cmdBuild buildOptions = do shake opts $ do addFetchURLRule cacheDir - addGitCloneRule cacheDir addPrepareSourceRule (buildOptsInputDir buildOptions) cacheDir addPrepareSdistRule outputDirRoot phony "buildAction" (buildAction buildOptions) diff --git a/app/Foliage/GitClone.hs b/app/Foliage/GitClone.hs deleted file mode 100644 index c780cb9..0000000 --- a/app/Foliage/GitClone.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# 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, 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 - if alreadyCloned - then command_ [Cwd path] "git" ["fetch"] - else 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} diff --git a/app/Foliage/PrepareSource.hs b/app/Foliage/PrepareSource.hs index 4d4ae02..40123e0 100644 --- a/app/Foliage/PrepareSource.hs +++ b/app/Foliage/PrepareSource.hs @@ -15,7 +15,6 @@ 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 @@ -70,8 +69,8 @@ addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run tarballPath <- fetchURL uri extractFromTarball tarballPath mSubdir srcDir GitHubSource repo rev mSubdir -> do - workDir <- gitClone repo rev - let packageDir = maybe workDir (workDir ) mSubdir + workingCopy <- gitCheckout cacheDir repo rev + let packageDir = maybe workingCopy (workingCopy ) mSubdir copyDirectoryContents packageDir srcDir let patchesDir = inputDir unPackageName pkgName prettyShow pkgVersion "patches" @@ -120,6 +119,20 @@ 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" + copyDirectoryContents :: FilePath -> FilePath -> Action () copyDirectoryContents source destination = cmd_ diff --git a/foliage.cabal b/foliage.cabal index 9d5d66a..55d3e51 100644 --- a/foliage.cabal +++ b/foliage.cabal @@ -27,7 +27,6 @@ executable foliage Foliage.CmdCreateKeys Foliage.CmdImportIndex Foliage.FetchURL - Foliage.GitClone Foliage.HackageSecurity Foliage.Meta Foliage.Meta.Aeson diff --git a/tests/Tests.hs b/tests/Tests.hs index d1639a3..5348018 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -40,6 +40,10 @@ main = do 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 From ac429ccf4a51d513fda8e0d61e1db55a0642b46d Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 13 Nov 2023 15:48:19 +0100 Subject: [PATCH 6/8] Re-add custom rule for GitClone and use git worktree to prepare source This re-uses the git repository in the _cache/git// directory, but uses a temporary directory to get the worktree for a given rev to prepare the per-package directory in _cache/. --- app/Foliage/CmdBuild.hs | 2 ++ app/Foliage/GitClone.hs | 55 ++++++++++++++++++++++++++++++++++++ app/Foliage/PrepareSource.hs | 31 +++++++++----------- foliage.cabal | 1 + 4 files changed, 72 insertions(+), 17 deletions(-) create mode 100644 app/Foliage/GitClone.hs diff --git a/app/Foliage/CmdBuild.hs b/app/Foliage/CmdBuild.hs index c44b4ad..51e4118 100644 --- a/app/Foliage/CmdBuild.hs +++ b/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) diff --git a/app/Foliage/GitClone.hs b/app/Foliage/GitClone.hs new file mode 100644 index 0000000..0d57907 --- /dev/null +++ b/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} diff --git a/app/Foliage/PrepareSource.hs b/app/Foliage/PrepareSource.hs index 40123e0..0bce371 100644 --- a/app/Foliage/PrepareSource.hs +++ b/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,17 @@ 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 + command_ [Cwd repoDir] "git" ["worktree", "prune"] + +-- | Copy all contents from one directory to another. copyDirectoryContents :: FilePath -> FilePath -> Action () copyDirectoryContents source destination = cmd_ diff --git a/foliage.cabal b/foliage.cabal index 55d3e51..9d5d66a 100644 --- a/foliage.cabal +++ b/foliage.cabal @@ -27,6 +27,7 @@ executable foliage Foliage.CmdCreateKeys Foliage.CmdImportIndex Foliage.FetchURL + Foliage.GitClone Foliage.HackageSecurity Foliage.Meta Foliage.Meta.Aeson From 745c03c173428ea4edda839c2d0aff2f498c64ad Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 13 Nov 2023 16:02:30 +0100 Subject: [PATCH 7/8] Use untracked version of doesDirectoryExist in GitClone --- app/Foliage/GitClone.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/app/Foliage/GitClone.hs b/app/Foliage/GitClone.hs index 0d57907..c16bcb8 100644 --- a/app/Foliage/GitClone.hs +++ b/app/Foliage/GitClone.hs @@ -10,12 +10,13 @@ module Foliage.GitClone ( ) where -import Development.Shake +import Development.Shake hiding (doesDirectoryExist) import Development.Shake.Classes import Development.Shake.FilePath import Development.Shake.Rule import Foliage.Meta (GitHubRepo) import GHC.Generics (Generic) +import System.Directory (doesDirectoryExist) newtype GitClone = GitClone {repo :: GitHubRepo} deriving (Eq, Generic) @@ -45,7 +46,7 @@ addGitCloneRule cacheDir = addBuiltinRule noLint noIdentity run run GitClone{repo} _old _mode = do let path = cacheDir "git" show repo - alreadyCloned <- doesDirectoryExist path + alreadyCloned <- liftIO $ doesDirectoryExist path if alreadyCloned then command_ [Cwd path] "git" ["fetch"] else do From ca51e1bc4fb4e75adfa4a7cb04bcb40ac204d811 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 13 Nov 2023 16:07:26 +0100 Subject: [PATCH 8/8] Not use Show instance for GitHubRepo and Rev --- app/Foliage/GitClone.hs | 8 ++++---- app/Foliage/Meta.hs | 16 ++++++++++------ app/Foliage/PrepareSource.hs | 2 +- 3 files changed, 15 insertions(+), 11 deletions(-) diff --git a/app/Foliage/GitClone.hs b/app/Foliage/GitClone.hs index c16bcb8..78b5c17 100644 --- a/app/Foliage/GitClone.hs +++ b/app/Foliage/GitClone.hs @@ -14,7 +14,7 @@ import Development.Shake hiding (doesDirectoryExist) import Development.Shake.Classes import Development.Shake.FilePath import Development.Shake.Rule -import Foliage.Meta (GitHubRepo) +import Foliage.Meta (GitHubRepo, gitHubRepoToString) import GHC.Generics (Generic) import System.Directory (doesDirectoryExist) @@ -23,7 +23,7 @@ newtype GitClone = GitClone {repo :: GitHubRepo} deriving newtype (NFData) instance Show GitClone where - show GitClone{repo} = "gitClone " <> show repo + show GitClone{repo} = "gitClone " <> gitHubRepoToString repo instance Hashable GitClone @@ -44,13 +44,13 @@ addGitCloneRule cacheDir = addBuiltinRule noLint noIdentity run where run :: BuiltinRun GitClone FilePath run GitClone{repo} _old _mode = do - let path = cacheDir "git" show repo + 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/" <> show repo <> ".git" + let url = "https://github.com/" <> gitHubRepoToString repo <> ".git" command_ [] "git" ["clone", "--recursive", url, path] return $ RunResult{runChanged = ChangedRecomputeDiff, runStore = "", runValue = path} diff --git a/app/Foliage/Meta.hs b/app/Foliage/Meta.hs index abd11af..c83eabb 100644 --- a/app/Foliage/Meta.hs +++ b/app/Foliage/Meta.hs @@ -24,7 +24,9 @@ module Foliage.Meta ( pattern URISource, pattern GitHubSource, GitHubRepo (..), + gitHubRepoToString, GitHubRev (..), + gitHubRevToString, UTCTime, latestRevisionNumber, packageVersionSourceToUri, @@ -51,16 +53,18 @@ import Toml (TomlCodec, (.=)) import Toml qualified newtype GitHubRepo = GitHubRepo {unGitHubRepo :: Text} - deriving (Eq, Binary, Hashable, NFData) via Text + deriving (Show, Eq, Binary, Hashable, NFData) via Text -instance Show GitHubRepo where - show = T.unpack . unGitHubRepo +gitHubRepoToString :: GitHubRepo -> String +gitHubRepoToString = + T.unpack . unGitHubRepo newtype GitHubRev = GitHubRev {unGitHubRev :: Text} - deriving (Eq, Binary, Hashable, NFData) via Text + deriving (Show, Eq, Binary, Hashable, NFData) via Text -instance Show GitHubRev where - show = T.unpack . unGitHubRev +gitHubRevToString :: GitHubRev -> String +gitHubRevToString = + T.unpack . unGitHubRev data PackageVersionSource = URISource diff --git a/app/Foliage/PrepareSource.hs b/app/Foliage/PrepareSource.hs index 0bce371..ea6e707 100644 --- a/app/Foliage/PrepareSource.hs +++ b/app/Foliage/PrepareSource.hs @@ -123,7 +123,7 @@ addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run 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 repoDir] "git" ["worktree", "add", tmpDir, gitHubRevToString rev] command_ [Cwd tmpDir] "git" ["submodule", "update", "--init"] let packageDir = maybe tmpDir (tmpDir ) mSubdir copyDirectoryContents packageDir outDir