;;; 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.
;;;
#: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 (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)
(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)))))
(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
(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)))
(_
#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
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) '())))
+
(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)))
- (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)
+ ;; 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
(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.
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