git-download: Use “builtin:git-download” when available.

Fixes <https://issues.guix.gnu.org/63331>.

Longer-term this will remove Git from the derivation graph when its sole
use is to perform a checkout for a fixed-output derivation, thereby
breaking dependency cycles that can arise in these situations.

* guix/git-download.scm (git-fetch): Rename to…
(git-fetch/in-band): … this.  Deal with GIT or GUILE being #f.
(git-fetch/built-in, built-in-builders*, git-fetch): New procedures.
* tests/builders.scm ("git-fetch, file URI"): New test.
This commit is contained in:
Ludovic Courtès 2023-09-11 15:28:09 +02:00
parent c4a1d69a69
commit 13b0cf85eb
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 91 additions and 10 deletions

View file

@ -27,6 +27,7 @@ (define-module (guix git-download)
#:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix modules)
#:use-module ((guix derivations) #:select (raw-derivation))
#:autoload (guix build-system gnu) (standard-packages)
#:autoload (guix download) (%download-fallback-test)
#:autoload (git bindings) (libgit2-init!)
@ -78,15 +79,19 @@ (define (git-package)
(let ((distro (resolve-interface '(gnu packages version-control))))
(module-ref distro 'git-minimal)))
(define* (git-fetch ref hash-algo hash
#:optional name
#:key (system (%current-system)) (guile (default-guile))
(git (git-package)))
"Return a fixed-output derivation that fetches REF, a <git-reference>
object. The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(define* (git-fetch/in-band ref hash-algo hash
#:optional name
#:key (system (%current-system))
(guile (default-guile))
(git (git-package)))
"Return a fixed-output derivation that performs a Git checkout of REF, using
GIT and GUILE (thus, said derivation depends on GIT and GUILE).
This method is deprecated in favor of the \"builtin:git-download\" builder.
It will be removed when versions of guix-daemon implementing
\"builtin:git-download\" will be sufficiently widespread."
(define inputs
`(("git" ,git)
`(("git" ,(or git (git-package)))
;; When doing 'git clone --recursive', we need sed, grep, etc. to be
;; available so that 'git submodule' works.
@ -154,7 +159,8 @@ (define recursive?
#:recursive? recursive?
#:git-command "git")))))
(mlet %store-monad ((guile (package->derivation guile system)))
(mlet %store-monad ((guile (package->derivation (or guile (default-guile))
system)))
(gexp->derivation (or name "git-checkout") build
;; Use environment variables and a fixed script name so
@ -181,6 +187,54 @@ (define recursive?
#:recursive? #t
#:guile-for-build guile)))
(define* (git-fetch/built-in ref hash-algo hash
#:optional name
#:key (system (%current-system)))
"Return a fixed-output derivation that performs a Git checkout of REF, using
the \"builtin:git-download\" derivation builder.
This is an \"out-of-band\" download in that the returned derivation does not
explicitly depend on Git, Guile, etc. Instead, the daemon performs the
download by itself using its own dependencies."
(raw-derivation (or name "git-checkout") "builtin:git-download" '()
#:system system
#:hash-algo hash-algo
#:hash hash
#:recursive? #t
#:env-vars
`(("url" . ,(object->string
(match (%download-fallback-test)
('content-addressed-mirrors
"https://example.org/does-not-exist")
(_
(git-reference-url ref)))))
("commit" . ,(git-reference-commit ref))
("recursive?" . ,(object->string
(git-reference-recursive? ref))))
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
#:local-build? #t))
(define built-in-builders*
(store-lift built-in-builders))
(define* (git-fetch ref hash-algo hash
#:optional name
#:key (system (%current-system))
guile git)
"Return a fixed-output derivation that fetches REF, a <git-reference>
object. The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(mlet %store-monad ((builtins (built-in-builders*)))
(if (member "git-download" builtins)
(git-fetch/built-in ref hash-algo hash name
#:system system)
(git-fetch/in-band ref hash-algo hash name
#:system system
#:guile guile
#:git git))))
(define (git-version version revision commit)
"Return the version string for packages using git-download."
;; git-version is almost exclusively executed while modules are being loaded.

View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012-2015, 2018-2019, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net>
;;;
;;; This file is part of GNU Guix.
@ -20,6 +20,7 @@
(define-module (tests builders)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module (guix build-system)
#:use-module (guix build-system gnu)
#:use-module (guix build gnu-build-system)
@ -31,9 +32,12 @@ (define-module (tests builders)
#:use-module (guix base32)
#:use-module (guix derivations)
#:use-module (gcrypt hash)
#:use-module ((guix hash) #:select (file-hash*))
#:use-module (guix tests)
#:use-module (guix tests git)
#:use-module (guix packages)
#:use-module (gnu packages bootstrap)
#:use-module ((ice-9 ftw) #:select (scandir))
#:use-module (ice-9 match)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1)
@ -84,6 +88,29 @@ (define url-fetch*
(and (file-exists? out)
(valid-path? %store out))))
(test-equal "git-fetch, file URI"
'("." ".." "a.txt" "b.scm")
(let ((nonce (random-text)))
(with-temporary-git-repository directory
`((add "a.txt" ,nonce)
(add "b.scm" "#t")
(commit "Commit.")
(tag "v1.0.0" "The tag."))
(run-with-store %store
(mlet* %store-monad ((hash
-> (file-hash* directory
#:algorithm (hash-algorithm sha256)
#:recursive? #t))
(drv (git-fetch
(git-reference
(url (string-append "file://" directory))
(commit "v1.0.0"))
'sha256 hash
"git-fetch-test")))
(mbegin %store-monad
(built-derivations (list drv))
(return (scandir (derivation->output-path drv)))))))))
(test-assert "gnu-build-system"
(build-system? gnu-build-system))