;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com>
+;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix gexp)
+ #:autoload (guix git-download)
+ (git-reference-url git-reference-commit git-reference-recursive?)
#: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)
#:use-module (ice-9 ftw)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:export (%repository-cache-directory
latest-repository-commit
commit-difference
commit-relation
+ commit-descendant?
+ commit-id?
+
+ remote-refs
git-checkout
git-checkout?
git-checkout-url
git-checkout-branch
git-checkout-commit
- git-checkout-recursive?))
+ git-checkout-recursive?
+
+ git-reference->git-checkout))
(define %repository-cache-directory
(make-parameter (string-append (cache-directory #:ensure? #f)
(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."
(lambda ()
(mkdir-p directory)
- (let ((auth-method (%make-auth-ssh-agent)))
- (clone url directory
- (make-clone-options
- #:fetch-options (make-default-fetch-options)))))
+ (clone url directory
+ (make-clone-options
+ #:fetch-options (make-default-fetch-options))))
(lambda _
(false-if-exception (rmdir directory)))))
(last (string-split url #\/)) ".git" "")
"-" (string-take sha1 7)))
+(define (commit-id? str)
+ "Return true if STR is likely a Git commit ID, false otherwise---e.g., if it
+is a tag name. This is based on a simple heuristic so use with care!"
+ (and (= (string-length str) 40)
+ (string-every char-set:hex-digit str)))
+
(define (resolve-reference repository ref)
"Resolve the branch, commit or tag specified by REF, and return the
corresponding Git object."
(let ((oid (reference-target
(branch-lookup repository branch BRANCH-REMOTE))))
(object-lookup repository oid)))
+ (('symref . symref)
+ (let ((oid (reference-name->oid repository symref)))
+ (object-lookup repository oid)))
(('commit . commit)
(let ((len (string-length commit)))
;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
(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))))
- ;; OID may point to a "tag" object, but it can also point directly
- ;; to a "commit" object, as surprising as it may seem. Return that
- ;; object, whatever that is.
- (object-lookup repository oid))))))
+ (let* ((oid (reference-name->oid repository
+ (string-append "refs/tags/" tag)))
+ (obj (object-lookup repository oid)))
+ ;; OID may designate an "annotated tag" object or a "commit" object.
+ ;; Return the commit object in both cases.
+ (if (= OBJ-TAG (object-type obj))
+ (object-lookup repository
+ (tag-target-id (tag-lookup repository oid)))
+ obj))))))
(define (switch-to-ref repository ref)
"Switch to REPOSITORY's branch, commit or tag specified by REF. Return the
(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
"/" (submodule-path submodule))))
(with-repository directory repository
(update-submodules repository
+ #:fetch-options fetch-options
#:log-port log-port)))))
(repository-submodules repository)))
"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
(_
#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.
(define* (update-cached-checkout url
#:key
- (ref '(branch . "master"))
+ (ref '())
recursive?
(check-out? #t)
starting-commit
REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value
the associated data: [<branch name> | <sha1> | <tag name> | <string>].
+If REF is the empty list, the remote HEAD is used.
When RECURSIVE? is true, check out submodules as well, if any.
;; made little sense since the cache should be transparent to them. So
;; here we append "origin/" if it's missing and otherwise keep it.
(match ref
+ (() '(symref . "refs/remotes/origin/HEAD"))
(('branch . branch)
`(branch . ,(if (string-prefix? "origin/" branch)
branch
(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)))
- (let ((auth-method (%make-auth-ssh-agent)))
- (remote-fetch (remote-lookup repository "origin")
- #:fetch-options (make-default-fetch-options))))
+ (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.
;; 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)))
(log-port (%make-void-port "w"))
(cache-directory
(%repository-cache-directory))
- (ref '(branch . "master")))
+ (ref '()))
"Return two values: the content of the git repository at URL copied into a
store directory and the sha1 of the top level commit in this directory. The
reference to be checkout, once the repository is fetched, is specified by REF.
REF is pair whose key is [branch | commit | tag] and value the associated
-data, respectively [<branch name> | <sha1> | <tag name>].
+data, respectively [<branch name> | <sha1> | <tag name>]. If REF is the empty
+list, the remote HEAD is used.
When RECURSIVE? is true, check out submodules as well, if any.
'descendant
'unrelated))))))
+(define (commit-descendant? new old)
+ "Return true if NEW is the descendant of one of OLD, a list of commits.
+
+When the expected result is likely #t, this is faster than using
+'commit-relation' since fewer commits need to be traversed."
+ (let ((old (list->setq old)))
+ (let loop ((commits (list new))
+ (visited (setq)))
+ (match commits
+ (()
+ #f)
+ (_
+ ;; Perform a breadth-first search as this is likely going to
+ ;; terminate more quickly than a depth-first search.
+ (let ((commits (remove (cut set-contains? visited <>) commits)))
+ (or (any (cut set-contains? old <>) commits)
+ (loop (append-map commit-parents commits)
+ (fold set-insert visited commits)))))))))
+
+\f
+;;
+;;; 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))))))
+
\f
;;;
;;; Checkouts.
git-checkout make-git-checkout
git-checkout?
(url git-checkout-url)
- (branch git-checkout-branch (default "master"))
+ (branch git-checkout-branch (default #f))
(commit git-checkout-commit (default #f)) ;#f | tag | commit
(recursive? git-checkout-recursive? (default #f)))
+(define (git-reference->git-checkout reference)
+ "Convert the <git-reference> REFERENCE to an equivalent <git-checkout>."
+ (git-checkout
+ (url (git-reference-url reference))
+ (commit (git-reference-commit reference))
+ (recursive? (git-reference-recursive? reference))))
+
(define* (latest-repository-commit* url #:key ref recursive? log-port)
;; Monadic variant of 'latest-repository-commit'.
(lambda (store)
(match checkout
(($ <git-checkout> url branch commit recursive?)
(latest-repository-commit* url
- #:ref (if commit
- `(tag-or-commit . ,commit)
- `(branch . ,branch))
+ #:ref (cond (commit
+ `(tag-or-commit . ,commit))
+ (branch
+ `(branch . ,branch))
+ (else '()))
#:recursive? recursive?
#:log-port (current-error-port)))))
HCoop / jackhill / guix / guix.git / blobdiff