diff options
| -rw-r--r-- | guix/git.scm | 86 |
1 files changed, 79 insertions, 7 deletions
diff --git a/guix/git.scm b/guix/git.scm index 0666f0c0a9..e2daa78f6b 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,6 +43,11 @@ git-checkout-url git-checkout-branch)) +;; XXX: Use this hack instead of #:autoload to avoid compilation errors. +;; See <http://bugs.gnu.org/12202>. +(module-autoload! (current-module) + '(git submodule) '(repository-submodules)) + (define %repository-cache-directory (make-parameter (string-append (cache-directory #:ensure? #f) "/checkouts"))) @@ -57,11 +62,15 @@ (define* (url-cache-directory url #:optional (cache-directory - (%repository-cache-directory))) + (%repository-cache-directory)) + #:key recursive?) "Return the directory associated to URL in %repository-cache-directory." (string-append cache-directory "/" - (bytevector->base32-string (sha256 (string->utf8 url))))) + (bytevector->base32-string + (sha256 (string->utf8 (if recursive? + (string-append "R:" url) + url)))))) (define (clone* url directory) "Clone git repository at URL into DIRECTORY. Upon failure, @@ -119,18 +128,62 @@ OID (roughly the commit hash) corresponding to REF." (reset repository obj RESET_HARD) (object-id obj)) +(define (call-with-repository directory proc) + (let ((repository #f)) + (dynamic-wind + (lambda () + (set! repository (repository-open directory))) + (lambda () + (proc repository)) + (lambda () + (repository-close! repository))))) + +(define-syntax-rule (with-repository directory repository exp ...) + "Open the repository at DIRECTORY and bind REPOSITORY to it within the +dynamic extent of EXP." + (call-with-repository directory + (lambda (repository) exp ...))) + +(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 (false-if-exception (resolve-interface '(git submodule))) + (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.~%")))) + (define* (update-cached-checkout url #:key (ref '(branch . "master")) + recursive? + (log-port (%make-void-port "w")) (cache-directory (url-cache-directory - url (%repository-cache-directory)))) + url (%repository-cache-directory) + #:recursive? recursive?))) "Update the cached checkout of URL to REF in CACHE-DIRECTORY. Return two values: the cache directory name, and the SHA1 commit (a string) corresponding to 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>]. + +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 @@ -150,6 +203,8 @@ data, respectively [<branch name> | <sha1> | <tag name>]." ;; Only fetch remote if it has not been cloned just before. (when cache-exists? (remote-fetch (remote-lookup repository "origin"))) + (when recursive? + (update-submodules repository #:log-port log-port)) (let ((oid (switch-to-ref repository canonical-ref))) ;; Reclaim file descriptors and memory mappings associated with @@ -162,6 +217,7 @@ data, respectively [<branch name> | <sha1> | <tag name>]." (define* (latest-repository-commit store url #:key + recursive? (log-port (%make-void-port "w")) (cache-directory (%repository-cache-directory)) @@ -172,21 +228,33 @@ 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>]. +When RECURSIVE? is true, check out submodules as well, if any. + Git repositories are kept in the cache directory specified by %repository-cache-directory parameter. Log progress and checkout info to LOG-PORT." (define (dot-git? file stat) (and (string=? (basename file) ".git") - (eq? 'directory (stat:type stat)))) + (or (eq? 'directory (stat:type stat)) + + ;; Submodule checkouts end up with a '.git' regular file that + ;; contains metadata about where their actual '.git' directory + ;; lives. + (and recursive? + (eq? 'regular (stat:type stat)))))) (format log-port "updating checkout of '~a'...~%" url) (let*-values (((checkout commit) (update-cached-checkout url + #:recursive? recursive? #:ref ref #:cache-directory - (url-cache-directory url cache-directory))) + (url-cache-directory url cache-directory + #:recursive? + recursive?) + #:log-port log-port)) ((name) (url+commit->name url commit))) (format log-port "retrieved commit ~a~%" commit) @@ -244,3 +312,7 @@ Log progress and checkout info to LOG-PORT." `(commit . ,commit) `(branch . ,branch)) #:log-port (current-error-port))))) + +;; Local Variables: +;; eval: (put 'with-repository 'scheme-indent-function 2) +;; End: |