rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

git: Support recursive updates of submodules. 

* guix/git.scm: Autoload (git submodule).
(url-cache-directory): Add #:recursive? and honor it.
(call-with-repository): New procedure.
(with-repository): New macro.
(update-submodules): New procedure.
(update-cached-checkout): Add #:recursive? and #:log-port and honor
them.
(latest-repository-commit): Add #:recursive? and honor it.
[dot-git?]: Recognize ".git" regular files when RECURSIVE? is true.
This commit is contained in:
Ludovic Courtès 2019-02-08 09:12:07 +01:00 committed by Ludovic Courtès
parent 92becc3f15
commit 60cbc6a8df
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 79 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
guix/git.scm
View File

@ -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: