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.

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 =

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

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}

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