From 135a170b219bdd3e019bd8e443f8c69f24b9e772 Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Thu, 21 Sep 2023 18:27:36 +0100 Subject: [PATCH] Do not call `git fetch` on git dependency if ref already exists in clone (#2379) During path resolution, `git fetch` is called on every git dependency clone. It's desirable to reduce the number of `git fetch` calls because it makes a network call. This PR changes the git dependency resolution to only call `git fetch` if the existing clone does not already contain the specified ref. --- .../FromParsed/Analysis/PathResolver.hs | 7 +- src/Juvix/Data/Effect/Git/Base.hs | 14 +++- src/Juvix/Data/Effect/Git/Process.hs | 21 +++--- .../Commands/compile-dependencies.smoke.yaml | 64 +++++++++++++++++++ 4 files changed, 91 insertions(+), 15 deletions(-) diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs index b2dc49b44..c9ce57284 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/PathResolver.hs @@ -121,11 +121,8 @@ getDependencyPath i = case i ^. packageDepdendencyInfoDependency of r <- rootBuildDir <$> asks (^. envRoot) let cloneDir = r relDependenciesDir relDir (T.unpack (g ^. gitDependencyName)) cloneArgs = CloneArgs {_cloneArgsCloneDir = cloneDir, _cloneArgsRepoUrl = g ^. gitDependencyUrl} - errorHandler' = errorHandler cloneDir - scoped @CloneArgs @Git cloneArgs $ do - fetch errorHandler' - checkout errorHandler' (g ^. gitDependencyRef) - return cloneDir + scoped @CloneArgs @Git cloneArgs $ + fetchOnNoSuchRefAndRetry (errorHandler cloneDir) (`checkout` (g ^. gitDependencyRef)) >> return cloneDir where errorHandler :: Path Abs Dir -> GitError -> Sem (Git ': r) a errorHandler p c = diff --git a/src/Juvix/Data/Effect/Git/Base.hs b/src/Juvix/Data/Effect/Git/Base.hs index 21abc0df8..c7696468d 100644 --- a/src/Juvix/Data/Effect/Git/Base.hs +++ b/src/Juvix/Data/Effect/Git/Base.hs @@ -22,8 +22,20 @@ data GitError data Git m a where Fetch :: (GitError -> m ()) -> Git m () Checkout :: (GitError -> m ()) -> GitRef -> Git m () - HeadRef :: (GitError -> m GitRef) -> Git m GitRef + NormalizeRef :: (GitError -> m GitRef) -> GitRef -> Git m GitRef makeSem ''Git type GitClone = Scoped CloneArgs Git + +headRef :: (Member Git r) => (GitError -> Sem r GitRef) -> Sem r GitRef +headRef h = normalizeRef h "HEAD" + +-- | If an action fails because a ref does not exist in the clone, first do a fetch and then retry. +fetchOnNoSuchRefAndRetry :: forall r a. (Member Git r) => (GitError -> Sem r a) -> ((GitError -> Sem r a) -> Sem r a) -> Sem r a +fetchOnNoSuchRefAndRetry handler action = action retryHandler + where + retryHandler :: GitError -> Sem r a + retryHandler = \case + NoSuchRef _ -> fetch (void . handler) >> action handler + e -> handler e diff --git a/src/Juvix/Data/Effect/Git/Process.hs b/src/Juvix/Data/Effect/Git/Process.hs index 9e77771ea..0c82f7bf4 100644 --- a/src/Juvix/Data/Effect/Git/Process.hs +++ b/src/Juvix/Data/Effect/Git/Process.hs @@ -53,9 +53,13 @@ checkValidGitClone = void gitHeadRef isValidGitClone :: (Members '[Process, Reader CloneEnv] r) => Sem r Bool isValidGitClone = isRight <$> runError @GitProcessError checkValidGitClone +-- | Return the normal form of the passed git reference +gitNormalizeRef :: forall r. (Members '[Process, Error GitProcessError, Reader CloneEnv] r) => Text -> Sem r Text +gitNormalizeRef ref = T.strip <$> runGitCmdInDir' ["rev-parse", "--verify", ref <> "^{commit}"] + -- | Return the HEAD ref of the clone gitHeadRef :: (Members '[Process, Error GitProcessError, Reader CloneEnv] r) => Sem r Text -gitHeadRef = T.strip <$> runGitCmdInDir' ["rev-parse", "HEAD"] +gitHeadRef = gitNormalizeRef "HEAD" -- | Checkout the clone at a particular ref gitCheckout :: (Members '[Process, Error GitProcessError, Reader CloneEnv] r) => Text -> Sem r () @@ -88,14 +92,11 @@ handleNotACloneError errorHandler eff = catch @GitProcessError eff $ \case GitCmdError GitCmdErrorDetails {_gitCmdErrorDetailsExitCode = ExitFailure 128} -> runTSimple (return NotAClone) >>= bindTSimple errorHandler e -> throw e -handleNoSuchRefError :: (Member (Error GitProcessError) r, Monad m) => (GitError -> m x) -> GitRef -> Tactical e m r x -> Tactical e m r x -handleNoSuchRefError errorHandler ref eff = catch @GitProcessError eff $ \case - GitCmdError GitCmdErrorDetails {_gitCmdErrorDetailsExitCode = ExitFailure 1} -> runTSimple (return (NoSuchRef ref)) >>= bindTSimple errorHandler +handleNormalizeRefError :: (Member (Error GitProcessError) r, Monad m) => (GitError -> m x) -> GitRef -> Tactical e m r x -> Tactical e m r x +handleNormalizeRefError errorHandler ref eff = catch @GitProcessError eff $ \case + GitCmdError GitCmdErrorDetails {_gitCmdErrorDetailsExitCode = ExitFailure 128} -> runTSimple (return (NoSuchRef ref)) >>= bindTSimple errorHandler e -> throw e -handleCheckoutError :: (Member (Error GitProcessError) r, Monad m) => (GitError -> m x) -> GitRef -> Tactical e m r x -> Tactical e m r x -handleCheckoutError errorHandler ref eff = handleNoSuchRefError errorHandler ref (handleNotACloneError errorHandler eff) - runGitProcess :: forall r a. (Members '[Log, Files, Process, Error GitProcessError, Internet] r) => @@ -110,9 +111,11 @@ runGitProcess = interpretScopedH allocator handler handler :: forall q r0 x. Path Abs Dir -> Git (Sem r0) x -> Tactical Git (Sem r0) (Opaque q ': r) x handler p eff = case eff of - HeadRef errorHandler -> handleNotACloneError errorHandler (runReader env gitHeadRef >>= pureT) Fetch errorHandler -> handleNotACloneError errorHandler (runReader env gitFetch >>= pureT) - Checkout errorHandler ref -> handleCheckoutError errorHandler ref (runReader env (gitCheckout ref) >>= pureT) + Checkout errorHandler ref -> do + void (handleNormalizeRefError errorHandler ref (runReader env (void (gitNormalizeRef ref)) >>= pureT)) + handleNotACloneError errorHandler (runReader env (gitCheckout ref) >>= pureT) + NormalizeRef errorHandler ref -> handleNormalizeRefError errorHandler ref (runReader env (gitNormalizeRef ref) >>= pureT) where env :: CloneEnv env = CloneEnv {_cloneEnvDir = p} diff --git a/tests/smoke/Commands/compile-dependencies.smoke.yaml b/tests/smoke/Commands/compile-dependencies.smoke.yaml index 8d8225e8b..f5713b413 100644 --- a/tests/smoke/Commands/compile-dependencies.smoke.yaml +++ b/tests/smoke/Commands/compile-dependencies.smoke.yaml @@ -561,3 +561,67 @@ tests: stdout: contains: duplicate exit-status: 1 + + - name: git-dependencies-no-fetch-if-ref-exists-in-clone + command: + shell: + - bash + script: | + temp=$(mktemp -d) + trap 'rm -rf -- "$temp"' EXIT + + # create dependency + mkdir $temp/dep + cd $temp/dep + git init + + cat <<-EOF > HelloDep.juvix + module HelloDep; + import Stdlib.Prelude open; + main : IO := printStringLn "Hello from dep"; + EOF + touch juvix.yaml + + git add -A + git commit -m "commit1" + + dep1hash=$(git rev-parse HEAD) + + # create project that uses dependency + mkdir $temp/base + cd $temp/base + + cat <<-EOF > juvix.yaml + name: HelloWorld + main: HelloWorld.juvix + dependencies: + - .juvix-build/stdlib + - git: + url: $temp/dep + name: dep1 + ref: $dep1hash + version: 0.1.0 + EOF + + cat <<-EOF > HelloWorld.juvix + -- HelloWorld.juvix + module HelloWorld; + + import Stdlib.Prelude open; + import HelloDep; + + main : IO := HelloDep.main; + EOF + + # compile project + juvix compile HelloWorld.juvix + + # delete the dependency to check that it's not required + rm -rf $temp/dep + + # compile project + juvix compile HelloWorld.juvix + stderr: "" + stdout: + contains: cloning + exit-status: 0