summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludovic.courtes@inria.fr>2021-09-10 15:49:45 +0200
committerLudovic Courtès <ludo@gnu.org>2021-09-18 23:08:32 +0200
commit05f44c2d858a1e7b13c90362c35fa86bdc4d5a24 (patch)
tree6396646b89b43d143104a3f4d352ba85360a38b4
parent6ec81c31c0c6d136ad7366e985083eaee34f7980 (diff)
git: 'update-cached-checkout' can fall back to SWH when cloning.
Fixes <https://issues.guix.gnu.org/44187>. Reported by zimoun <zimon.toutoune@gmail.com>. * guix/git.scm (GITERR_HTTP): New variable. (clone-from-swh, clone/swh-fallback): New procedures. (update-cached-checkout): Use 'clone/swh-fallback' instead of 'clone*'.
-rw-r--r--guix/git.scm48
1 files changed, 46 insertions, 2 deletions
diff --git a/guix/git.scm b/guix/git.scm
index bbff4fc890..719af950ad 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -34,8 +34,9 @@
#:use-module (guix records)
#:use-module (guix gexp)
#:use-module (guix sets)
- #:use-module ((guix diagnostics) #:select (leave))
+ #:use-module ((guix diagnostics) #:select (leave warning))
#:use-module (guix progress)
+ #:autoload (guix swh) (swh-download)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
@@ -182,6 +183,13 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
(lambda args
(make-fetch-options auth-method)))))
+(define GITERR_HTTP
+ ;; Guile-Git <= 0.5.2 lacks this constant.
+ (let ((errors (resolve-interface '(git errors))))
+ (if (module-defined? errors 'GITERR_HTTP)
+ (module-ref errors 'GITERR_HTTP)
+ 34)))
+
(define (clone* url directory)
"Clone git repository at URL into DIRECTORY. Upon failure,
make sure no empty directory is left behind."
@@ -344,6 +352,42 @@ definitely available in REPOSITORY, false otherwise."
(_
#f)))
+(define (clone-from-swh url tag-or-commit output)
+ "Attempt to clone TAG-OR-COMMIT (a string), which originates from URL, using
+a copy archived at Software Heritage."
+ (call-with-temporary-directory
+ (lambda (bare)
+ (and (swh-download url tag-or-commit bare
+ #:archive-type 'git-bare)
+ (let ((repository (clone* bare output)))
+ (remote-set-url! repository "origin" url)
+ repository)))))
+
+(define (clone/swh-fallback url ref cache-directory)
+ "Like 'clone', but fallback to Software Heritage if the repository cannot be
+found at URL."
+ (define (inaccessible-url-error? err)
+ (let ((class (git-error-class err))
+ (code (git-error-code err)))
+ (or (= class GITERR_HTTP) ;404 or similar
+ (= class GITERR_NET)))) ;unknown host, etc.
+
+ (catch 'git-error
+ (lambda ()
+ (clone* url cache-directory))
+ (lambda (key err)
+ (match ref
+ (((or 'commit 'tag-or-commit) . commit)
+ (if (inaccessible-url-error? err)
+ (or (clone-from-swh url commit cache-directory)
+ (begin
+ (warning (G_ "revision ~a of ~a \
+could not be fetched from Software Heritage~%")
+ commit url)
+ (throw key err)))
+ (throw key err)))
+ (_ (throw key err))))))
+
(define cached-checkout-expiration
;; Return the expiration time procedure for a cached checkout.
;; TODO: Honor $GUIX_GIT_CACHE_EXPIRATION.
@@ -410,7 +454,7 @@ it unchanged."
(let* ((cache-exists? (openable-repository? cache-directory))
(repository (if cache-exists?
(repository-open cache-directory)
- (clone* url cache-directory))))
+ (clone/swh-fallback url ref cache-directory))))
;; Only fetch remote if it has not been cloned just before.
(when (and cache-exists?
(not (reference-available? repository ref)))