[bug#74481] [PATCH 1/2] git: Catch Git errors when updating cached checkout.

[Simon Tournier <zimon.toutoune@gmail.com>]

* guix/git.scm (resolve-reference): Catch Git error when reference does not
exist and return #false.
(switch-to-ref): Adjust.
(update-cached-checkout)[close-and-clean!]: New helper.
Catch Git error when reference does not exist and warn.
Return #false values when reference does not exist.

Change-Id: If6e244fe40ebee978ec8de51a6a68bcbd4a2c79e
---
 guix/git.scm | 128 ++++++++++++++++++++++++++++++---------------------
 1 file changed, 75 insertions(+), 53 deletions(-)

diff --git a/guix/git.scm b/guix/git.scm
index 410cd4c153..328e2d5c8c 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -5,7 +5,7 @@
 ;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;; Copyright © 2023 Tobias Geerinckx-Rice <me@tobias.gr>
-;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2023, 2024 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -265,7 +265,7 @@ (define (tag->commit repository tag)
 
 (define (resolve-reference repository ref)
   "Resolve the branch, commit or tag specified by REF, and return the
-corresponding Git object."
+corresponding Git object. Return #false if REF is not found."
   (let resolve ((ref ref))
     (match ref
       (('branch . branch)
@@ -281,9 +281,12 @@ (define (resolve-reference repository ref)
          ;; can't be sure it's available.  Furthermore, 'string->oid' used to
          ;; read out-of-bounds when passed a string shorter than 40 chars,
          ;; which is why we delay calls to it below.
-         (if (< len 40)
-             (object-lookup-prefix repository (string->oid commit) len)
-             (object-lookup repository (string->oid commit)))))
+         (catch 'git-error
+           (lambda ()
+             (if (< len 40)
+                 (object-lookup-prefix repository (string->oid commit) len)
+                 (object-lookup repository (string->oid commit))))
+           (lambda _ #f))))
       (('tag-or-commit . str)
        (cond ((and (string-contains str "-g")
                    (match (string-split str #\-)
@@ -300,7 +303,10 @@ (define (resolve-reference repository ref)
               => (lambda (commit) (resolve `(commit . ,commit))))
              ((or (> (string-length str) 40)
                   (not (string-every char-set:hex-digit str)))
-              (resolve `(tag . ,str)))      ;definitely a tag
+              (catch 'git-error         ;definitely a tag
+                (lambda ()
+                  (resolve `(tag . ,str)))
+                (lambda _ #f)))
              (else
               (catch 'git-error
                 (lambda ()
@@ -336,13 +342,15 @@ (define (switch-to-ref repository ref)
   (define obj
     (resolve-reference repository ref))
 
-  (reset repository obj RESET_HARD)
+  (and obj
+       (begin
+         (reset repository obj RESET_HARD)
 
-  ;; There might still be untracked files in REPOSITORY due to an interrupted
-  ;; checkout for example; delete them.
-  (delete-untracked-files repository)
+         ;; There might still be untracked files in REPOSITORY due to an interrupted
+         ;; checkout for example; delete them.
+         (delete-untracked-files repository)
 
-  (object-id obj))
+         (object-id obj))))
 
 (define (call-with-repository directory proc)
   (let ((repository #f))
@@ -562,6 +570,31 @@ (define* (update-cached-checkout url
                    (string-append directory "/" file)))
                 (or (scandir directory) '())))
 
+  (define (close-and-clean! repository)
+    (repository-close! repository)
+
+    ;; Update CACHE-DIRECTORY's mtime to so the cache logic sees it.
+    (match (gettimeofday)
+      ((seconds . microseconds)
+       (let ((nanoseconds (* 1000 microseconds)))
+         (utime cache-directory
+                seconds seconds
+                nanoseconds nanoseconds))))
+
+    ;; Run 'git gc' if needed.
+    (maybe-run-git-gc cache-directory)
+
+    ;; When CACHE-DIRECTORY is a sub-directory of the default cache
+    ;; directory, remove expired checkouts that are next to it.
+    (let ((parent (dirname cache-directory)))
+      (when (string=? parent (%repository-cache-directory))
+        (maybe-remove-expired-cache-entries parent cache-entries
+                                            #:entry-expiration
+                                            cached-checkout-expiration
+                                            #:delete-entry delete-checkout
+                                            #:cleanup-period
+                                            %checkout-cache-cleanup-period))))
+
   (define canonical-ref
     ;; We used to require callers to specify "origin/" for each branch, which
     ;; made little sense since the cache should be transparent to them.  So
@@ -583,56 +616,45 @@ (define* (update-cached-checkout url
      ;; Only fetch remote if it has not been cloned just before.
      (when (and cache-exists?
                 (not (reference-available? repository ref)))
-       (remote-fetch (remote-lookup repository "origin")
-                     #:fetch-options (make-default-fetch-options)))
+       (catch 'git-error
+         (lambda ()
+           (remote-fetch (remote-lookup repository "origin")
+                         #:fetch-options (make-default-fetch-options)))
+         (lambda _
+           (warning (G_ "Git cannot update the cache of ~a~%") url))))
      (when recursive?
        (update-submodules repository #:log-port log-port
                           #:fetch-options (make-default-fetch-options)))
 
      ;; Note: call 'commit-relation' from here because it's more efficient
      ;; than letting users re-open the checkout later on.
-     (let* ((oid      (if check-out?
+     (let ((oid      (if check-out?
                           (switch-to-ref repository canonical-ref)
                           (object-id
-                           (resolve-reference repository canonical-ref))))
-            (new      (and starting-commit
-                           (commit-lookup repository oid)))
-            (old      (and starting-commit
-                           (false-if-git-not-found
-                            (commit-lookup repository
-                                           (string->oid starting-commit)))))
-            (relation (and starting-commit
-                           (if old
-                               (commit-relation old new)
-                               'unrelated))))
-
-       ;; Reclaim file descriptors and memory mappings associated with
-       ;; REPOSITORY as soon as possible.
-       (repository-close! repository)
-
-       ;; Update CACHE-DIRECTORY's mtime to so the cache logic sees it.
-       (match (gettimeofday)
-         ((seconds . microseconds)
-          (let ((nanoseconds (* 1000 microseconds)))
-            (utime cache-directory
-                   seconds seconds
-                   nanoseconds nanoseconds))))
-
-       ;; Run 'git gc' if needed.
-       (maybe-run-git-gc cache-directory)
-
-       ;; When CACHE-DIRECTORY is a sub-directory of the default cache
-       ;; directory, remove expired checkouts that are next to it.
-       (let ((parent (dirname cache-directory)))
-         (when (string=? parent (%repository-cache-directory))
-           (maybe-remove-expired-cache-entries parent cache-entries
-                                               #:entry-expiration
-                                               cached-checkout-expiration
-                                               #:delete-entry delete-checkout
-                                               #:cleanup-period
-                                               %checkout-cache-cleanup-period)))
-
-       (values cache-directory (oid->string oid) relation)))))
+                           (resolve-reference repository canonical-ref)))))
+       (if (not oid)
+           (begin
+             (warning (G_ "Git cannot find the reference ~a~%") (match canonical-ref
+                                                                  ((_ . ref) ref)))
+             (close-and-clean! repository)
+             (values #f #f #f))
+           (let* ((new      (and starting-commit
+                                 (commit-lookup repository oid)))
+                  (old      (and starting-commit
+                                 (false-if-git-not-found
+                                  (commit-lookup repository
+                                                 (string->oid starting-commit)))))
+                  (relation (and starting-commit
+                                 (if old
+                                     (commit-relation old new)
+                                     'unrelated))))
+
+             ;; Reclaim file descriptors and memory mappings associated with
+             ;; REPOSITORY as soon as possible.
+
+             (close-and-clean! repository)
+
+             (values cache-directory (oid->string oid) relation)))))))
 
 (define* (latest-repository-commit store url
                                    #:key
-- 
2.46.0