diff options
Diffstat (limited to 'guix/git.scm')
| -rw-r--r-- | guix/git.scm | 143 |
1 files changed, 128 insertions, 15 deletions
diff --git a/guix/git.scm b/guix/git.scm index 776b03f33a..dc2ca1be84 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com> +;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,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 commit-id?) #:use-module (rnrs bytevectors) #:use-module (ice-9 format) #:use-module (ice-9 match) @@ -56,6 +58,8 @@ commit-difference commit-relation + remote-refs + git-checkout git-checkout? git-checkout-url @@ -179,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." @@ -223,15 +234,29 @@ corresponding Git object." (object-lookup-prefix repository (string->oid commit) len) (object-lookup repository (string->oid commit))))) (('tag-or-commit . str) - (if (or (> (string-length str) 40) - (not (string-every char-set:hex-digit str))) - (resolve `(tag . ,str)) ;definitely a tag - (catch 'git-error - (lambda () - (resolve `(tag . ,str))) - (lambda _ - ;; There's no such tag, so it must be a commit ID. - (resolve `(commit . ,str)))))) + (cond ((and (string-contains str "-g") + (match (string-split str #\-) + ((version ... revision g+commit) + (if (and (> (string-length g+commit) 4) + (string-every char-set:digit revision) + (string-every char-set:hex-digit + (string-drop g+commit 1))) + ;; Looks like a 'git describe' style ID, like + ;; v1.3.0-7-gaa34d4d28d. + (string-drop g+commit 1) + #f)) + (_ #f))) + => (lambda (commit) (resolve `(commit . ,commit)))) + ((or (> (string-length str) 40) + (not (string-every char-set:hex-digit str))) + (resolve `(tag . ,str))) ;definitely a tag + (else + (catch 'git-error + (lambda () + (resolve `(tag . ,str))) + (lambda _ + ;; There's no such tag, so it must be a commit ID. + (resolve `(commit . ,str))))))) (('tag . tag) (let ((oid (reference-name->oid repository (string-append "refs/tags/" tag)))) @@ -283,13 +308,15 @@ dynamic extent of EXP." (report-git-error err)))) (define* (update-submodules repository - #:key (log-port (current-error-port))) + #:key (log-port (current-error-port)) + (fetch-options #f)) "Update the submodules of REPOSITORY, a Git repository object." (for-each (lambda (name) (let ((submodule (submodule-lookup repository name))) (format log-port (G_ "updating submodule '~a'...~%") name) - (submodule-update submodule) + (submodule-update submodule + #:fetch-options fetch-options) ;; Recurse in SUBMODULE. (let ((directory (string-append @@ -297,6 +324,7 @@ dynamic extent of EXP." "/" (submodule-path submodule)))) (with-repository directory repository (update-submodules repository + #:fetch-options fetch-options #:log-port log-port))))) (repository-submodules repository))) @@ -314,7 +342,8 @@ dynamic extent of EXP." "Return true if REF, a reference such as '(commit . \"cabba9e\"), is definitely available in REPOSITORY, false otherwise." (match ref - (('commit . commit) + ((or ('commit . commit) + ('tag-or-commit . (? commit-id? commit))) (let ((len (string-length commit)) (oid (string->oid commit))) (false-if-git-not-found @@ -324,6 +353,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. @@ -390,14 +455,15 @@ 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))) (remote-fetch (remote-lookup repository "origin") #:fetch-options (make-default-fetch-options))) (when recursive? - (update-submodules repository #:log-port log-port)) + (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. @@ -420,6 +486,14 @@ it unchanged." ;; 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)))) + ;; 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))) @@ -544,6 +618,45 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or (if (set-contains? oldest new) 'descendant 'unrelated)))))) + +;; +;;; Remote operations. +;;; + +(define* (remote-refs url #:key tags?) + "Return the list of references advertised at Git repository URL. If TAGS? +is true, limit to only refs/tags." + (define (ref? ref) + ;; Like `git ls-remote --refs', only show actual references. + (and (string-prefix? "refs/" ref) + (not (string-suffix? "^{}" ref)))) + + (define (tag? ref) + (string-prefix? "refs/tags/" ref)) + + (define (include? ref) + (and (ref? ref) + (or (not tags?) (tag? ref)))) + + (define (remote-head->ref remote) + (let ((name (remote-head-name remote))) + (and (include? name) + name))) + + (with-libgit2 + (call-with-temporary-directory + (lambda (cache-directory) + (let* ((repository (repository-init cache-directory)) + ;; Create an in-memory remote so we don't touch disk. + (remote (remote-create-anonymous repository url))) + (remote-connect remote) + + (let* ((remote-heads (remote-ls remote)) + (refs (filter-map remote-head->ref remote-heads))) + ;; Wait until we're finished with the repository before closing it. + (remote-disconnect remote) + (repository-close! repository) + refs)))))) ;;; |