git: Require Guile-Git 0.3.0 or later.
* guix/git.scm (auth-supported?): Remove. (clone*): Inline code that was dependent on AUTH-SUPPORTED?. (update-cached-checkout): Likewise. (resolve-reference): Remove check for 'object-lookup-prefix' and use it unconditionally. (load-git-submodules): Remove. (update-submodules): Use 'repository-submodules', 'submodule-lookup', etc. unconditionally. (update-cached-checkout): Use 'repository-close!' unconditionally. * m4/guix.m4 (GUIX_CHECK_GUILE_GIT): New macro. * configure.ac: Use it and error out when it fails. * doc/guix.texi (Requirements): Bump to Guile-Git 0.3.0.master
parent
830ea72799
commit
59bb1ae3a9
|
@ -144,6 +144,11 @@ if test "x$guix_cv_have_recent_guile_gcrypt" != "xyes"; then
|
||||||
AC_MSG_ERROR([A recent Guile-Gcrypt could not be found; please install it.])
|
AC_MSG_ERROR([A recent Guile-Gcrypt could not be found; please install it.])
|
||||||
fi
|
fi
|
||||||
|
|
||||||
|
GUIX_CHECK_GUILE_GIT
|
||||||
|
if test "x$guix_cv_have_recent_guile_git" != "xyes"; then
|
||||||
|
AC_MSG_ERROR([A recent Guile-Git could not be found; please install it.])
|
||||||
|
fi
|
||||||
|
|
||||||
dnl Check for Guile-zlib.
|
dnl Check for Guile-zlib.
|
||||||
GUILE_MODULE_AVAILABLE([have_guile_zlib], [(zlib)])
|
GUILE_MODULE_AVAILABLE([have_guile_zlib], [(zlib)])
|
||||||
if test "x$have_guile_zlib" != "xyes"; then
|
if test "x$have_guile_zlib" != "xyes"; then
|
||||||
|
|
|
@ -826,8 +826,8 @@ or later;
|
||||||
@item @uref{https://notabug.org/guile-lzlib/guile-lzlib, Guile-lzlib};
|
@item @uref{https://notabug.org/guile-lzlib/guile-lzlib, Guile-lzlib};
|
||||||
@item
|
@item
|
||||||
@c FIXME: Specify a version number once a release has been made.
|
@c FIXME: Specify a version number once a release has been made.
|
||||||
@uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, from August
|
@uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, version 0.3.0
|
||||||
2017 or later;
|
or later;
|
||||||
@item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON}
|
@item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON}
|
||||||
4.3.0 or later;
|
4.3.0 or later;
|
||||||
@item @url{https://www.gnu.org/software/make/, GNU Make}.
|
@item @url{https://www.gnu.org/software/make/, GNU Make}.
|
||||||
|
|
84
guix/git.scm
84
guix/git.scm
|
@ -20,6 +20,7 @@
|
||||||
(define-module (guix git)
|
(define-module (guix git)
|
||||||
#:use-module (git)
|
#:use-module (git)
|
||||||
#:use-module (git object)
|
#:use-module (git object)
|
||||||
|
#:use-module (git submodule)
|
||||||
#:use-module (guix i18n)
|
#:use-module (guix i18n)
|
||||||
#:use-module (guix base32)
|
#:use-module (guix base32)
|
||||||
#:use-module (gcrypt hash)
|
#:use-module (gcrypt hash)
|
||||||
|
@ -116,10 +117,6 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
|
||||||
(string-append "R:" url)
|
(string-append "R:" url)
|
||||||
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 (clone* url directory)
|
(define (clone* url directory)
|
||||||
"Clone git repository at URL into DIRECTORY. Upon failure,
|
"Clone git repository at URL into DIRECTORY. Upon failure,
|
||||||
make sure no empty directory is left behind."
|
make sure no empty directory is left behind."
|
||||||
|
@ -127,18 +124,10 @@ make sure no empty directory is left behind."
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(mkdir-p directory)
|
(mkdir-p directory)
|
||||||
|
|
||||||
;; Note: Explicitly pass options to work around the invalid default
|
(let ((auth-method (%make-auth-ssh-agent)))
|
||||||
;; value in Guile-Git: <https://bugs.gnu.org/29238>.
|
(clone url directory
|
||||||
(if (module-defined? (resolve-interface '(git))
|
(make-clone-options
|
||||||
'clone-init-options)
|
#:fetch-options (make-fetch-options auth-method)))))
|
||||||
(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)))
|
|
||||||
(lambda _
|
(lambda _
|
||||||
(false-if-exception (rmdir directory)))))
|
(false-if-exception (rmdir directory)))))
|
||||||
|
|
||||||
|
@ -167,12 +156,7 @@ corresponding Git object."
|
||||||
;; read out-of-bounds when passed a string shorter than 40 chars,
|
;; read out-of-bounds when passed a string shorter than 40 chars,
|
||||||
;; which is why we delay calls to it below.
|
;; which is why we delay calls to it below.
|
||||||
(if (< len 40)
|
(if (< len 40)
|
||||||
(if (module-defined? (resolve-interface '(git object))
|
(object-lookup-prefix repository (string->oid commit) len)
|
||||||
'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)))))
|
(object-lookup repository (string->oid commit)))))
|
||||||
(('tag-or-commit . str)
|
(('tag-or-commit . str)
|
||||||
(if (or (> (string-length str) 40)
|
(if (or (> (string-length str) 40)
|
||||||
|
@ -234,40 +218,23 @@ dynamic extent of EXP."
|
||||||
(lambda (key err)
|
(lambda (key err)
|
||||||
(report-git-error err))))
|
(report-git-error err))))
|
||||||
|
|
||||||
(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* (update-submodules repository
|
(define* (update-submodules repository
|
||||||
#:key (log-port (current-error-port)))
|
#:key (log-port (current-error-port)))
|
||||||
"Update the submodules of REPOSITORY, a Git repository object."
|
"Update the submodules of REPOSITORY, a Git repository object."
|
||||||
;; Guile-Git < 0.2.0 did not have (git submodule).
|
(for-each (lambda (name)
|
||||||
(if (load-git-submodules)
|
(let ((submodule (submodule-lookup repository name)))
|
||||||
(for-each (lambda (name)
|
(format log-port (G_ "updating submodule '~a'...~%")
|
||||||
(let ((submodule (submodule-lookup repository name)))
|
name)
|
||||||
(format log-port (G_ "updating submodule '~a'...~%")
|
(submodule-update submodule)
|
||||||
name)
|
|
||||||
(submodule-update submodule)
|
|
||||||
|
|
||||||
;; Recurse in SUBMODULE.
|
;; Recurse in SUBMODULE.
|
||||||
(let ((directory (string-append
|
(let ((directory (string-append
|
||||||
(repository-working-directory repository)
|
(repository-working-directory repository)
|
||||||
"/" (submodule-path submodule))))
|
"/" (submodule-path submodule))))
|
||||||
(with-repository directory repository
|
(with-repository directory repository
|
||||||
(update-submodules repository
|
(update-submodules repository
|
||||||
#:log-port log-port)))))
|
#:log-port log-port)))))
|
||||||
(repository-submodules repository))
|
(repository-submodules repository)))
|
||||||
(format (current-error-port)
|
|
||||||
(G_ "Support for submodules is missing; \
|
|
||||||
please upgrade Guile-Git.~%"))))
|
|
||||||
|
|
||||||
(define-syntax-rule (false-if-git-not-found exp)
|
(define-syntax-rule (false-if-git-not-found exp)
|
||||||
"Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised."
|
"Evaluate EXP, returning #false if a GIT_ENOTFOUND error is raised."
|
||||||
|
@ -331,12 +298,9 @@ it unchanged."
|
||||||
;; Only fetch remote if it has not been cloned just before.
|
;; Only fetch remote if it has not been cloned just before.
|
||||||
(when (and cache-exists?
|
(when (and cache-exists?
|
||||||
(not (reference-available? repository ref)))
|
(not (reference-available? repository ref)))
|
||||||
(if auth-supported?
|
(let ((auth-method (%make-auth-ssh-agent)))
|
||||||
(let ((auth-method (and auth-supported?
|
(remote-fetch (remote-lookup repository "origin")
|
||||||
(%make-auth-ssh-agent))))
|
#:fetch-options (make-fetch-options auth-method))))
|
||||||
(remote-fetch (remote-lookup repository "origin")
|
|
||||||
#:fetch-options (make-fetch-options auth-method)))
|
|
||||||
(remote-fetch (remote-lookup repository "origin"))))
|
|
||||||
(when recursive?
|
(when recursive?
|
||||||
(update-submodules repository #:log-port log-port))
|
(update-submodules repository #:log-port log-port))
|
||||||
|
|
||||||
|
@ -359,9 +323,7 @@ it unchanged."
|
||||||
|
|
||||||
;; Reclaim file descriptors and memory mappings associated with
|
;; Reclaim file descriptors and memory mappings associated with
|
||||||
;; REPOSITORY as soon as possible.
|
;; REPOSITORY as soon as possible.
|
||||||
(when (module-defined? (resolve-interface '(git repository))
|
(repository-close! repository)
|
||||||
'repository-close!)
|
|
||||||
(repository-close! repository))
|
|
||||||
|
|
||||||
(values cache-directory (oid->string oid) relation)))))
|
(values cache-directory (oid->string oid) relation)))))
|
||||||
|
|
||||||
|
|
22
m4/guix.m4
22
m4/guix.m4
|
@ -204,6 +204,28 @@ AC_DEFUN([GUIX_CHECK_GUILE_GCRYPT], [
|
||||||
fi])
|
fi])
|
||||||
])
|
])
|
||||||
|
|
||||||
|
dnl GUIX_CHECK_GUILE_GIT
|
||||||
|
dnl
|
||||||
|
dnl Check whether a recent-enough Guile-Git is available.
|
||||||
|
AC_DEFUN([GUIX_CHECK_GUILE_GIT], [
|
||||||
|
dnl Check whether we're using Guile-Git 0.3.0 or later. 0.3.0
|
||||||
|
dnl introduced SSH authentication support and more.
|
||||||
|
AC_CACHE_CHECK([whether Guile-Git is available and recent enough],
|
||||||
|
[guix_cv_have_recent_guile_git],
|
||||||
|
[GUILE_CHECK([retval],
|
||||||
|
[(use-modules (git) (git auth) (git submodule))
|
||||||
|
(let ((auth (%make-auth-ssh-agent)))
|
||||||
|
repository-close!
|
||||||
|
object-lookup-prefix
|
||||||
|
(make-clone-options
|
||||||
|
#:fetch-options (make-fetch-options auth)))])
|
||||||
|
if test "$retval" = 0; then
|
||||||
|
guix_cv_have_recent_guile_git="yes"
|
||||||
|
else
|
||||||
|
guix_cv_have_recent_guile_git="no"
|
||||||
|
fi])
|
||||||
|
])
|
||||||
|
|
||||||
dnl GUIX_TEST_ROOT_DIRECTORY
|
dnl GUIX_TEST_ROOT_DIRECTORY
|
||||||
AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
|
AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
|
||||||
AC_CACHE_CHECK([for unit test root directory],
|
AC_CACHE_CHECK([for unit test root directory],
|
||||||
|
|
Reference in New Issue