[bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts

[Maxim Cournoyer]

Hello,

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

> From: Ludovic Courtès <ludovic.courtes@inria.fr>
>
> The new builder makes it possible to break cycles that occurs when the
> fixed-output derivation for the source of a dependency of ‘git’ would
> itself depend on ‘git’.
>
> * guix/scripts/perform-download.scm (perform-git-download): New
> procedure.
> (perform-download): Move fixed-output derivation check to…
> (guix-perform-download): … here.  Invoke ‘perform-download’ or
> ‘perform-git-download’ depending on what ‘derivation-builder’ returns.
> * nix/libstore/builtins.cc (builtins): Add “git-download”.
> * tests/derivations.scm ("built-in-builders"): Update.
> ("'git-download' built-in builder")
> ("'git-download' built-in builder, invalid hash")
> ("'git-download' built-in builder, invalid commit")
> ("'git-download' built-in builder, not found"): New tests.
> ---
>  guix/scripts/perform-download.scm |  52 +++++++++++++---
>  nix/libstore/builtins.cc          |   5 +-
>  tests/derivations.scm             | 100 +++++++++++++++++++++++++++++-
>  3 files changed, 145 insertions(+), 12 deletions(-)
>
> diff --git a/guix/scripts/perform-download.scm 
> b/guix/scripts/perform-download.scm
> index c8f044e82e..a287e97528 100644
> --- a/guix/scripts/perform-download.scm
> +++ b/guix/scripts/perform-download.scm
> @@ -1,5 +1,5 @@
>  ;;; GNU Guix --- Functional package management for GNU
> -;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
> +;;; Copyright © 2016-2018, 2020, 2023 Ludovic Courtès <ludo@gnu.org>
>  ;;;
>  ;;; This file is part of GNU Guix.
>  ;;;
> @@ -21,7 +21,8 @@ (define-module (guix scripts perform-download)
>    #:use-module (guix scripts)
>    #:use-module (guix derivations)
>    #:use-module ((guix store) #:select (derivation-path? store-path?))
> -  #:use-module (guix build download)
> +  #:autoload   (guix build download) (url-fetch)
> +  #:autoload   (guix build git) (git-fetch-with-fallback)
>    #:use-module (ice-9 match)
>    #:export (guix-perform-download))
>  
> @@ -64,10 +65,6 @@ (define* (perform-download drv #:optional output
>             (drv-output (assoc-ref (derivation-outputs drv) "out"))
>             (algo       (derivation-output-hash-algo drv-output))
>             (hash       (derivation-output-hash drv-output)))
> -      (unless (and algo hash)
> -        (leave (G_ "~a is not a fixed-output derivation~%")
> -               (derivation-file-name drv)))
> -
>        ;; We're invoked by the daemon, which gives us write access to OUTPUT.
>        (when (url-fetch url output
>                         #:print-build-trace? print-build-trace?
> @@ -92,6 +89,33 @@ (define* (perform-download drv #:optional output
>          (when (and executable (string=? executable "1"))
>            (chmod output #o755))))))
>  
> +(define* (perform-git-download drv #:optional output
> +                               #:key print-build-trace?)
> +  "Perform the download described by DRV, a fixed-output derivation, to
> +OUTPUT.
> +
> +Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the
> +actual output is different from that when we're doing a 'bmCheck' or

I'd drop the 'we's and use impersonal imperative tense or at least
's/when we're doing/when doing/'.

> +'bmRepair' build."
> +  (derivation-let drv ((output* "out")

I'd name this variable just 'out', for consistency with the others.

> +                       (url "url")
> +                       (commit "commit")
> +                       (recursive? "recursive?"))
> +    (unless url
> +      (leave (G_ "~a: missing Git URL~%") (derivation-file-name drv)))
> +    (unless commit
> +      (leave (G_ "~a: missing Git commit~%") (derivation-file-name drv)))
> +
> +    (let* ((output     (or output output*))
> 
> +           (url        (call-with-input-string url read))
> +           (recursive? (and recursive?
> +                            (call-with-input-string recursive? read)))
> +           (drv-output (assoc-ref (derivation-outputs drv) "out"))
> +           (algo       (derivation-output-hash-algo drv-output))
> +           (hash       (derivation-output-hash drv-output)))
> +      (git-fetch-with-fallback url commit output
> +                               #:recursive? recursive?))))
> +
>  (define (assert-low-privileges)
>    (when (zero? (getuid))
>      (leave (G_ "refusing to run with elevated privileges (UID ~a)~%")
> @@ -120,8 +144,20 @@ (define-command (guix-perform-download . args)
>      (match args
>        (((? derivation-path? drv) (? store-path? output))
>         (assert-low-privileges)
> -       (let ((drv (read-derivation-from-file drv)))
> -         (perform-download drv output #:print-build-trace? 
> print-build-trace?)))
> +       (let* ((drv (read-derivation-from-file drv))
> +              (download (match (derivation-builder drv)
> +                          ("builtin:download" perform-download)
> +                          ("builtin:git-download" perform-git-download)
> +                          (unknown (leave (G_ "~a: unknown builtin builder")
> +                                          unknown))))
> +              (drv-output (assoc-ref (derivation-outputs drv) "out"))
> +              (algo       (derivation-output-hash-algo drv-output))
> +              (hash       (derivation-output-hash drv-output)))
> +         (unless (and hash algo)
> +           (leave (G_ "~a is not a fixed-output derivation~%")
> +                  (derivation-file-name drv)))
> +
> +         (download drv output #:print-build-trace? print-build-trace?)))
>        (("--version")
>         (show-version-and-exit))
>        (x
> diff --git a/nix/libstore/builtins.cc b/nix/libstore/builtins.cc
> index 4111ac4760..6bf467354a 100644
> --- a/nix/libstore/builtins.cc
> +++ b/nix/libstore/builtins.cc
> @@ -1,5 +1,5 @@
>  /* GNU Guix --- Functional package management for GNU
> -   Copyright (C) 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
> +   Copyright (C) 2016-2019, 2023 Ludovic Courtès <ludo@gnu.org>
>  
>     This file is part of GNU Guix.
>  
> @@ -58,7 +58,8 @@ static void builtinDownload(const Derivation &drv,
>  
>  static const std::map<std::string, derivationBuilder> builtins =
>  {
> -    { "download", builtinDownload }
> +    { "download", builtinDownload },
> +    { "git-download", builtinDownload }
>  };
>  
>  derivationBuilder lookupBuiltinBuilder(const std::string & name)
> diff --git a/tests/derivations.scm b/tests/derivations.scm
> index 66c777cfe7..e1312bd46b 100644
> --- a/tests/derivations.scm
> +++ b/tests/derivations.scm
> @@ -24,10 +24,15 @@ (define-module (test-derivations)
>    #:use-module (guix utils)
>    #:use-module ((gcrypt hash) #:prefix gcrypt:)
>    #:use-module (guix base32)
> +  #:use-module ((guix git) #:select (with-repository))
>    #:use-module (guix tests)
> +  #:use-module (guix tests git)
>    #:use-module (guix tests http)
>    #:use-module ((guix packages) #:select (package-derivation base32))
> -  #:use-module ((guix build utils) #:select (executable-file?))
> +  #:use-module ((guix build utils) #:select (executable-file? which))
> +  #:use-module ((guix hash) #:select (file-hash*))
> +  #:use-module ((git oid) #:select (oid->string))
> +  #:use-module ((git reference) #:select (reference-name->oid))
>    #:use-module (gnu packages bootstrap)
>    #:use-module ((gnu packages guile) #:select (guile-1.8))
>    #:use-module (srfi srfi-1)
> @@ -195,7 +200,7 @@ (define* (directory-contents dir #:optional (slurp 
> get-bytevector-all))
>                     (stat:ino (lstat file2))))))))
>  
>  (test-equal "built-in-builders"
> -  '("download")
> +  '("download" "git-download")
>    (built-in-builders %store))
>  
>  (test-assert "unknown built-in builder"
> @@ -290,6 +295,97 @@ (define* (directory-contents dir #:optional (slurp 
> get-bytevector-all))
>                           get-string-all)
>                         text))))))
>  
> +;; 'with-temporary-git-repository' relies on the 'git' command.
> +(unless (which (git-command)) (test-skip 1))

I'd expect the 'git' command to now be required by Autoconf at build
time, which should mean checking it here is not useful/required?

> +(test-equal "'git-download' built-in builder"
> +  `(("/a.txt" . "AAA")
> +    ("/b.scm" . "#t"))
> +  (let ((nonce (random-text)))
> +    (with-temporary-git-repository directory
> +        `((add "a.txt" "AAA")
> +          (add "b.scm" "#t")
> +          (commit ,nonce))
> +      (let* ((commit (with-repository directory repository
> +                       (oid->string
> +                        (reference-name->oid repository "HEAD"))))
> +             (drv (derivation %store "git-download"
> +                              "builtin:git-download" '()
> +                              #:env-vars
> +                              `(("url"
> +                                 . ,(object->string
> +                                     (string-append "file://" directory)))
> +                                ("commit" . ,commit))
> +                              #:hash-algo 'sha256
> +                              #:hash (file-hash* directory
> +                                                 #:algorithm
> +                                                 (gcrypt:hash-algorithm
> +                                                  gcrypt:sha256)
> +                                                 #:recursive? #t)
> +                              #:recursive? #t)))
> +        (build-derivations %store (list drv))
> +        (directory-contents (derivation->output-path drv) get-string-all)))))
> +
> +(unless (which (git-command)) (test-skip 1))
> +(test-assert "'git-download' built-in builder, invalid hash"
> +  (with-temporary-git-repository directory
> +      `((add "a.txt" "AAA")
> +        (add "b.scm" "#t")
> +        (commit "Commit!"))
> +    (let* ((commit (with-repository directory repository
> +                     (oid->string
> +                      (reference-name->oid repository "HEAD"))))
> +           (drv (derivation %store "git-download"
> +                            "builtin:git-download" '()
> +                            #:env-vars
> +                            `(("url"
> +                               . ,(object->string
> +                                   (string-append "file://" directory)))
> +                              ("commit" . ,commit))
> +                            #:hash-algo 'sha256
> +                            #:hash (gcrypt:sha256 #vu8())
> +                            #:recursive? #t)))
> +      (guard (c ((store-protocol-error? c)
> +                 (string-contains (store-protocol-error-message c) 
> "failed")))
> +        (build-derivations %store (list drv))
> +        #f))))
> +
> +(unless (which (git-command)) (test-skip 1))
> +(test-assert "'git-download' built-in builder, invalid commit"
> +  (with-temporary-git-repository directory
> +      `((add "a.txt" "AAA")
> +        (add "b.scm" "#t")
> +        (commit "Commit!"))
> +    (let* ((drv (derivation %store "git-download"
> +                            "builtin:git-download" '()
> +                            #:env-vars
> +                            `(("url"
> +                               . ,(object->string
> +                                   (string-append "file://" directory)))
> +                              ("commit"
> +                               . "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
> +                            #:hash-algo 'sha256
> +                            #:hash (gcrypt:sha256 #vu8())
> +                            #:recursive? #t)))
> +      (guard (c ((store-protocol-error? c)
> +                 (string-contains (store-protocol-error-message c) 
> "failed")))
> +        (build-derivations %store (list drv))
> +        #f))))
> +
> +(test-assert "'git-download' built-in builder, not found"
> +  (let* ((drv (derivation %store "git-download"
> +                          "builtin:git-download" '()
> +                          #:env-vars
> +                          `(("url" . "file:///does-not-exist.git")
> +                            ("commit"
> +                             . "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
> +                          #:hash-algo 'sha256
> +                          #:hash (gcrypt:sha256 #vu8())
> +                          #:recursive? #t)))
> +    (guard (c ((store-protocol-error? c)
> +               (string-contains (store-protocol-error-message c) "failed")))
> +      (build-derivations %store (list drv))
> +      #f)))
> +

Maybe the error message compared could be more precised, if it already
contains the necessary details?

Otherwise, well done!  LGTM with my above comments.

-- 
Thanks,
Maxim