diff mbox series

[bug#65866,7/8] git-download: Use “builtin:git-download” when available.

Message ID 2cd5b127be6d64e640e569f262cef3bbb89f58a6.1694441831.git.ludo@gnu.org
State New
Headers show
Series Add built-in builder for Git checkouts | expand

Commit Message

Ludovic Courtès Sept. 11, 2023, 2:25 p.m. UTC
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.
---
 guix/git-download.scm | 68 +++++++++++++++++++++++++++++++++++++------
 tests/builders.scm    | 29 +++++++++++++++++-
 2 files changed, 87 insertions(+), 10 deletions(-)

Comments

Maxim Cournoyer Sept. 20, 2023, 5:50 p.m. UTC | #1
Hello!

Ludovic Courtès <ludo@gnu.org> writes:

> 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.

Nitpick, but I find this usage of dynamic default argument on top of
default arguments inelegant; see my comments below for an
alternative.

> (git-fetch/built-in, built-in-builders*, git-fetch): New procedures.
> * tests/builders.scm ("git-fetch, file URI"): New test.
> ---
>  guix/git-download.scm | 68 +++++++++++++++++++++++++++++++++++++------
>  tests/builders.scm    | 29 +++++++++++++++++-
>  2 files changed, 87 insertions(+), 10 deletions(-)
>
> diff --git a/guix/git-download.scm b/guix/git-download.scm
> index f1f19397c6..505dff0a89 100644
> --- a/guix/git-download.scm
> +++ b/guix/git-download.scm
> @@ -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)))

Instead of using 'or' here to ensure git has a value, the default values
should have been copied to the new definition of git-fetch.

>  
>        ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
>        ;; available so that 'git submodule' works.
> @@ -154,7 +159,8 @@ (define* (git-fetch ref hash-algo hash
>                                       #: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,50 @@ (define* (git-fetch ref hash-algo hash
>                        #: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 without any dependency that performs a Git
> +checkout of REF, using the \"builtin:git-download\" derivation builder."
> +  (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)

As mentioned above, I'd have kept the default values for guile and git
here.

> +  "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.
> diff --git a/tests/builders.scm b/tests/builders.scm
> index 0b5577c7a3..619caa5f31 100644
> --- a/tests/builders.scm
> +++ b/tests/builders.scm
> @@ -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))

Pretty neat test!  LGTM.  You can add a 'Reviewed-by:' git trailer in
Magit easily with 'C-u C-c C-r' :-)
Ludovic Courtès Sept. 22, 2023, 9:58 p.m. UTC | #2
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

> Ludovic Courtès <ludo@gnu.org> writes:
>
>> 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.
>
> Nitpick, but I find this usage of dynamic default argument on top of
> default arguments inelegant; see my comments below for an
> alternative.

Ah, let me explain…

>> +(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)))
>
> Instead of using 'or' here to ensure git has a value, the default values
> should have been copied to the new definition of git-fetch.

[...]

>> +(define* (git-fetch ref hash-algo hash
>> +                    #:optional name
>> +                    #:key (system (%current-system))
>> +                    guile git)
>
> As mentioned above, I'd have kept the default values for guile and git
> here.

The reason ‘guile’ and ‘git’ default to #f here is because we don’t need
them in what we expect to be the common case eventually:

>> +  "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)

So it’s an optimization to avoid module lookups when they’re
unnecessary.

I hope that makes sense!

Ludo’.
Maxim Cournoyer Sept. 25, 2023, 3:56 p.m. UTC | #3
Hello,

Ludovic Courtès <ludo@gnu.org> writes:

> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> Ludovic Courtès <ludo@gnu.org> writes:
>>
>>> 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.
>>
>> Nitpick, but I find this usage of dynamic default argument on top of
>> default arguments inelegant; see my comments below for an
>> alternative.
>
> Ah, let me explain…
>
>>> +(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)))
>>
>> Instead of using 'or' here to ensure git has a value, the default values
>> should have been copied to the new definition of git-fetch.
>
> [...]
>
>>> +(define* (git-fetch ref hash-algo hash
>>> +                    #:optional name
>>> +                    #:key (system (%current-system))
>>> +                    guile git)
>>
>> As mentioned above, I'd have kept the default values for guile and git
>> here.
>
> The reason ‘guile’ and ‘git’ default to #f here is because we don’t need
> them in what we expect to be the common case eventually:
>
>>> +  "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)
>
> So it’s an optimization to avoid module lookups when they’re
> unnecessary.
>
> I hope that makes sense!

Oh!  I guess it does, but shouldn't git-fetch/in-band also not use guile
and git as default values then?  I'd like to see the same strategy used
in both places for consistency, with an added explanatory comment (in
the user-facing git-fetch) with what you explained here :-).
diff mbox series

Patch

diff --git a/guix/git-download.scm b/guix/git-download.scm
index f1f19397c6..505dff0a89 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -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* (git-fetch ref hash-algo hash
                                      #: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,50 @@  (define* (git-fetch ref hash-algo hash
                       #: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 without any dependency that performs a Git
+checkout of REF, using the \"builtin:git-download\" derivation builder."
+  (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.
diff --git a/tests/builders.scm b/tests/builders.scm
index 0b5577c7a3..619caa5f31 100644
--- a/tests/builders.scm
+++ b/tests/builders.scm
@@ -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))