;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix git)
#:use-module (git)
#:use-module (git object)
+ #:use-module (git submodule)
#:use-module (guix i18n)
#:use-module (guix base32)
+ #:use-module (guix cache)
#:use-module (gcrypt hash)
- #:use-module ((guix build utils) #:select (mkdir-p))
+ #:use-module ((guix build utils)
+ #:select (mkdir-p delete-file-recursively))
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix gexp)
#:use-module (guix sets)
+ #:use-module ((guix diagnostics) #:select (leave))
+ #:use-module (guix progress)
#: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-34)
#:export (%repository-cache-directory
honor-system-x509-certificates!
+ url-cache-directory
with-repository
+ with-git-error-handling
+ false-if-git-not-found
update-cached-checkout
+ url+commit->name
latest-repository-commit
commit-difference
+ commit-relation
git-checkout
git-checkout?
git-checkout-url
- git-checkout-branch))
+ git-checkout-branch
+ git-checkout-commit
+ git-checkout-recursive?))
(define %repository-cache-directory
(make-parameter (string-append (cache-directory #:ensure? #f)
(string-append "R:" url)
url))))))
-;; Authentication appeared in Guile-Git 0.3.0, check if it is available.
-(define auth-supported?
- (false-if-exception (resolve-interface '(git auth))))
+(define (show-progress progress)
+ "Display a progress bar as we fetch Git code. PROGRESS is an
+<indexer-progress> record from (git)."
+ (define total
+ (indexer-progress-total-objects progress))
+
+ (define hundredth
+ (match (quotient (indexer-progress-total-objects progress) 100)
+ (0 1)
+ (x x)))
+
+ (define-values (done label)
+ (if (< (indexer-progress-received-objects progress) total)
+ (values (indexer-progress-received-objects progress)
+ (G_ "receiving objects"))
+ (values (indexer-progress-indexed-objects progress)
+ (G_ "indexing objects"))))
+
+ (define %
+ (* 100. (/ done total)))
+
+ (when (and (< % 100) (zero? (modulo done hundredth)))
+ (erase-current-line (current-error-port))
+ (let ((width (max (- (current-terminal-columns)
+ (string-length label) 7)
+ 3)))
+ (format (current-error-port) "~a ~3,d% ~a"
+ label (inexact->exact (round %))
+ (progress-bar % width)))
+ (force-output (current-error-port)))
+
+ (when (= % 100.)
+ ;; We're done, erase the line.
+ (erase-current-line (current-error-port))
+ (force-output (current-error-port)))
+
+ ;; Return true to indicate that we should go on.
+ #t)
+
+(define (make-default-fetch-options)
+ "Return the default fetch options."
+ (let ((auth-method (%make-auth-ssh-agent)))
+ ;; The #:transfer-progress and #:proxy-url options appeared in Guile-Git
+ ;; 0.4.0. Omit them when using an older version.
+ (catch 'wrong-number-of-args
+ (lambda ()
+ (make-fetch-options auth-method
+ ;; Guile-Git doesn't distinguish between these.
+ #:proxy-url (or (getenv "http_proxy")
+ (getenv "https_proxy"))
+ #:transfer-progress
+ (and (isatty? (current-error-port))
+ show-progress)))
+ (lambda args
+ (make-fetch-options auth-method)))))
(define (clone* url directory)
"Clone git repository at URL into DIRECTORY. Upon failure,
(lambda ()
(mkdir-p directory)
- ;; Note: Explicitly pass options to work around the invalid default
- ;; value in Guile-Git: <https://bugs.gnu.org/29238>.
- (if (module-defined? (resolve-interface '(git))
- 'clone-init-options)
- (let ((auth-method (and auth-supported?
- (%make-auth-ssh-agent))))
- (clone url directory
- (if auth-supported?
- (make-clone-options
- #:fetch-options (make-fetch-options auth-method))
- (clone-init-options))))
- (clone url directory)))
+ (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 (resolve-reference repository ref)
+ "Resolve the branch, commit or tag specified by REF, and return the
+corresponding Git object."
+ (let resolve ((ref ref))
+ (match ref
+ (('branch . branch)
+ (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
+ ;; 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)))))
+ (('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))))))
+ (('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))))))
+
(define (switch-to-ref repository ref)
"Switch to REPOSITORY's branch, commit or tag specified by REF. Return the
OID (roughly the commit hash) corresponding to REF."
(define obj
- (let resolve ((ref ref))
- (match ref
- (('branch . branch)
- (let ((oid (reference-target
- (branch-lookup repository branch BRANCH-REMOTE))))
- (object-lookup repository oid)))
- (('commit . commit)
- (let ((len (string-length commit)))
- ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we
- ;; 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)
- (if (module-defined? (resolve-interface '(git object))
- 'object-lookup-prefix)
- (object-lookup-prefix repository (string->oid commit) len)
- (raise (condition
- (&message
- (message "long Git object ID is required")))))
- (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))))))
- (('tag . tag)
- (let ((oid (reference-name->oid repository
- (string-append "refs/tags/" tag))))
- ;; Get the commit that the tag at OID refers to. This is not
- ;; strictly needed, but it's more consistent to always return the
- ;; OID of a commit.
- (object-lookup repository
- (tag-target-id (tag-lookup repository oid))))))))
+ (resolve-reference repository ref))
(reset repository obj RESET_HARD)
(object-id obj))
(call-with-repository directory
(lambda (repository) exp ...)))
-(define (load-git-submodules)
- "Attempt to load (git submodules), which was missing until Guile-Git 0.2.0.
-Return true on success, false on failure."
- (match (false-if-exception (resolve-interface '(git submodule)))
- (#f
- (set! load-git-submodules (const #f))
- #f)
- (iface
- (module-use! (resolve-module '(guix git)) iface)
- (set! load-git-submodules (const #t))
- #t)))
+(define (report-git-error error)
+ "Report the given Guile-Git error."
+ ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
+ ;; errors would be represented by integers.
+ (match error
+ ((? integer? error) ;old Guile-Git
+ (leave (G_ "Git error ~a~%") error))
+ ((? git-error? error) ;new Guile-Git
+ (leave (G_ "Git error: ~a~%") (git-error-message error)))))
+
+(define-syntax-rule (with-git-error-handling body ...)
+ (catch 'git-error
+ (lambda ()
+ body ...)
+ (lambda (key err)
+ (report-git-error err))))
(define* (update-submodules repository
#:key (log-port (current-error-port)))
"Update the submodules of REPOSITORY, a Git repository object."
- ;; Guile-Git < 0.2.0 did not have (git submodule).
- (if (load-git-submodules)
- (for-each (lambda (name)
- (let ((submodule (submodule-lookup repository name)))
- (format log-port (G_ "updating submodule '~a'...~%")
- name)
- (submodule-update submodule)
-
- ;; Recurse in SUBMODULE.
- (let ((directory (string-append
- (repository-working-directory repository)
- "/" (submodule-path submodule))))
- (with-repository directory repository
- (update-submodules repository
- #:log-port log-port)))))
- (repository-submodules repository))
- (format (current-error-port)
- (G_ "Support for submodules is missing; \
-please upgrade Guile-Git.~%"))))
+ (for-each (lambda (name)
+ (let ((submodule (submodule-lookup repository name)))
+ (format log-port (G_ "updating submodule '~a'...~%")
+ name)
+ (submodule-update submodule)
+
+ ;; Recurse in SUBMODULE.
+ (let ((directory (string-append
+ (repository-working-directory repository)
+ "/" (submodule-path submodule))))
+ (with-repository directory repository
+ (update-submodules repository
+ #:log-port log-port)))))
+ (repository-submodules repository)))
+
+(define-syntax-rule (false-if-git-not-found exp)
+ "Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised."
+ (catch 'git-error
+ (lambda ()
+ exp)
+ (lambda (key error . rest)
+ (if (= GIT_ENOTFOUND (git-error-code error))
+ #f
+ (apply throw key error rest)))))
(define (reference-available? repository ref)
"Return true if REF, a reference such as '(commit . \"cabba9e\"), is
definitely available in REPOSITORY, false otherwise."
(match ref
(('commit . commit)
- (catch 'git-error
- (lambda ()
- (->bool (commit-lookup repository (string->oid commit))))
- (lambda (key error . rest)
- (if (= GIT_ENOTFOUND (git-error-code error))
- #f
- (apply throw key error rest)))))
+ (let ((len (string-length commit))
+ (oid (string->oid commit)))
+ (false-if-git-not-found
+ (->bool (if (< len 40)
+ (object-lookup-prefix repository oid len OBJ-COMMIT)
+ (commit-lookup repository oid))))))
(_
#f)))
+(define cached-checkout-expiration
+ ;; Return the expiration time procedure for a cached checkout.
+ ;; TODO: Honor $GUIX_GIT_CACHE_EXPIRATION.
+
+ ;; Use the mtime rather than the atime to cope with file systems mounted
+ ;; with 'noatime'.
+ (file-expiration-time (* 90 24 3600) stat:mtime))
+
+(define %checkout-cache-cleanup-period
+ ;; Period for the removal of expired cached checkouts.
+ (* 5 24 3600))
+
+(define (delete-checkout directory)
+ "Delete DIRECTORY recursively, in an atomic fashion."
+ (let ((trashed (string-append directory ".trashed")))
+ (rename-file directory trashed)
+ (delete-file-recursively trashed)))
+
(define* (update-cached-checkout url
#:key
- (ref '(branch . "master"))
+ (ref '())
recursive?
+ (check-out? #t)
+ starting-commit
(log-port (%make-void-port "w"))
(cache-directory
(url-cache-directory
url (%repository-cache-directory)
#:recursive? recursive?)))
- "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two
+ "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return three
values: the cache directory name, and the SHA1 commit (a string) corresponding
-to REF.
+to REF, and the relation of the new commit relative to STARTING-COMMIT (if
+provided) as returned by 'commit-relation'.
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.
+
+When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave
+it unchanged."
+ (define (cache-entries directory)
+ (filter-map (match-lambda
+ ((or "." "..")
+ #f)
+ (file
+ (string-append directory "/" file)))
+ (or (scandir directory) '())))
-When RECURSIVE? is true, check out submodules as well, if any."
(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
;; 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
;; Only fetch remote if it has not been cloned just before.
(when (and cache-exists?
(not (reference-available? repository ref)))
- (if auth-supported?
- (let ((auth-method (and auth-supported?
- (%make-auth-ssh-agent))))
- (remote-fetch (remote-lookup repository "origin")
- #:fetch-options (make-fetch-options auth-method)))
- (remote-fetch (remote-lookup repository "origin"))))
+ (remote-fetch (remote-lookup repository "origin")
+ #:fetch-options (make-default-fetch-options)))
(when recursive?
(update-submodules repository #:log-port log-port))
- (let ((oid (switch-to-ref repository canonical-ref)))
+
+ ;; 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?
+ (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.
- (when (module-defined? (resolve-interface '(git repository))
- 'repository-close!)
- (repository-close! repository))
+ (repository-close! repository)
- (values cache-directory (oid->string oid))))))
+ ;; 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)))))
(define* (latest-repository-commit store url
#:key
(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.
(format log-port "updating checkout of '~a'...~%" url)
(let*-values
- (((checkout commit)
+ (((checkout commit _)
(update-cached-checkout url
#:recursive? recursive?
#:ref ref
that of OLD."
(let loop ((commits (list new))
(result '())
- (visited (commit-closure old (list->setq excluded))))
+ (visited (fold commit-closure
+ (setq)
+ (cons old excluded))))
(match commits
(()
(reverse result))
(cons head result)
(set-insert head visited)))))))
+(define (commit-relation old new)
+ "Return a symbol denoting the relation between OLD and NEW, two commit
+objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
+'unrelated, or 'self (OLD and NEW are the same commit)."
+ (if (eq? old new)
+ 'self
+ (let ((newest (commit-closure new)))
+ (if (set-contains? newest old)
+ 'ancestor
+ (let* ((seen (list->setq (commit-parents new)))
+ (oldest (commit-closure old seen)))
+ (if (set-contains? oldest new)
+ 'descendant
+ 'unrelated))))))
+
\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)))
(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