Package: guix-patches;
Reported by: Simon Tournier <zimon.toutoune <at> gmail.com>
Date: Fri, 22 Nov 2024 19:07:02 UTC
Severity: normal
Tags: patch
Done: Simon Tournier <zimon.toutoune <at> gmail.com>
Bug is archived. No further changes may be made.
Message #11 received at 74481 <at> debbugs.gnu.org (full text, mbox):
From: Simon Tournier <zimon.toutoune <at> gmail.com> To: 74481 <at> debbugs.gnu.org Cc: Simon Tournier <zimon.toutoune <at> gmail.com> Subject: [PATCH 1/2] git: Catch Git errors when updating cached checkout. Date: Fri, 22 Nov 2024 20:09:26 +0100
* 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 <at> gnu.org>
;;; Copyright © 2022 Maxime Devos <maximedevos <at> telenet.be>
;;; Copyright © 2023 Tobias Geerinckx-Rice <me <at> tobias.gr>
-;;; Copyright © 2023 Simon Tournier <zimon.toutoune <at> gmail.com>
+;;; Copyright © 2023, 2024 Simon Tournier <zimon.toutoune <at> 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.