unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
From: "Ludovic Courtès" <ludo@gnu.org>
To: 65866@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludovic.courtes@inria.fr>,
	"Christopher Baines" <guix@cbaines.net>,
	"Josselin Poiret" <dev@jpoiret.xyz>,
	"Ludovic Courtès" <ludo@gnu.org>,
	"Mathieu Othacehe" <othacehe@gnu.org>,
	"Ricardo Wurmus" <rekado@elephly.net>,
	"Simon Tournier" <zimon.toutoune@gmail.com>,
	"Tobias Geerinckx-Rice" <me@tobias.gr>
Subject: [bug#65866] [PATCH 4/8] daemon: Add “git-download” built-in builder.
Date: Mon, 11 Sep 2023 16:25:22 +0200	[thread overview]
Message-ID: <3c42634cb47dd7eaa81a198bc2d097ca74a973ed.1694441831.git.ludo@gnu.org> (raw)
In-Reply-To: <cover.1694441830.git.ludo@gnu.org>

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
+'bmRepair' build."
+  (derivation-let drv ((output* "out")
+                       (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))
+(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)))
+
 (test-equal "derivation-name"
   "foo-0.0"
   (let ((drv (derivation %store "foo-0.0" %bash '())))
-- 
2.41.0





  parent reply	other threads:[~2023-09-11 14:26 UTC|newest]

Thread overview: 51+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2023-09-11 14:23 [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts Ludovic Courtès
2023-09-11 14:25 ` [bug#65866] [PATCH 1/8] git-download: Move fallback code to (guix build git) Ludovic Courtès
2023-09-20 16:05   ` [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts Maxim Cournoyer
2023-09-20 16:40     ` Simon Tournier
2023-09-22 21:53     ` Ludovic Courtès
2023-09-11 14:25 ` [bug#65866] [PATCH 2/8] git-download: Honor the ‘GUIX_DOWNLOAD_FALLBACK_TEST’ environment variable Ludovic Courtès
2023-09-20 16:07   ` [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts Maxim Cournoyer
2023-09-11 14:25 ` [bug#65866] [PATCH 3/8] perform-download: Remove unused one-argument clause Ludovic Courtès
2023-09-20 16:09   ` [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts Maxim Cournoyer
2023-09-11 14:25 ` Ludovic Courtès [this message]
2023-09-20 17:32   ` Maxim Cournoyer
2023-09-21  7:42     ` Ludovic Courtès
2023-09-22 22:27       ` [bug#65866] [PATCH v2 " Ludovic Courtès
2023-09-22 22:27         ` [bug#65866] [PATCH v2 1/8] git-download: Move fallback code to (guix build git) Ludovic Courtès
2023-09-25  8:15           ` Simon Tournier
2023-09-25  9:24             ` [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts Ludovic Courtès
2023-09-25 12:13               ` Simon Tournier
2023-09-22 22:27         ` [bug#65866] [PATCH v2 2/8] git-download: Honor the ‘GUIX_DOWNLOAD_FALLBACK_TEST’ environment variable Ludovic Courtès
2023-09-22 22:27         ` [bug#65866] [PATCH v2 3/8] perform-download: Remove unused one-argument clause Ludovic Courtès
2023-09-22 22:28         ` [bug#65866] [PATCH v2 4/8] daemon: Add “git-download” built-in builder Ludovic Courtès
2023-09-22 22:28         ` [bug#65866] [PATCH v2 5/8] build: Add dependency on Git Ludovic Courtès
2023-09-25 13:59           ` Simon Tournier
2023-09-26 14:05             ` [bug#65866] Bootstrapping without the daemon and all that Ludovic Courtès
2023-09-26 17:04               ` Simon Tournier
2023-10-12 10:54                 ` Ludovic Courtès
2023-10-16  8:46                   ` Simon Tournier
2023-09-22 22:28         ` [bug#65866] [PATCH v2 6/8] perform-download: Use the ‘git’ command captured at configure time Ludovic Courtès
2023-09-22 22:28         ` [bug#65866] [PATCH v2 7/8] git-download: Use “builtin:git-download” when available Ludovic Courtès
2023-09-25  8:33           ` Simon Tournier
2023-09-25  9:23             ` [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts Ludovic Courtès
2023-09-25 12:37               ` Simon Tournier
2023-09-25 12:48               ` Simon Tournier
2023-09-25 15:49                 ` Maxim Cournoyer
2023-09-26 15:44                 ` bug#65866: " Ludovic Courtès
2023-09-26 17:13                   ` [bug#65866] " Simon Tournier
2023-10-01 15:02                     ` Ludovic Courtès
2023-10-16  9:11                       ` [bug#65866] Toward RFC? (was Re: [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts) Simon Tournier
2023-10-30 15:12                         ` Ludovic Courtès
2023-09-22 22:28         ` [bug#65866] [PATCH v2 8/8] tests: Assume ‘git’ is always available Ludovic Courtès
2023-09-11 14:25 ` [bug#65866] [PATCH 5/8] build: Add dependency on Git Ludovic Courtès
2023-09-20 17:57   ` [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts Maxim Cournoyer
2023-09-22 22:00     ` Ludovic Courtès
2023-09-25 15:59       ` Maxim Cournoyer
2023-09-11 14:25 ` [bug#65866] [PATCH 6/8] perform-git-download: Use the ‘git’ command captured at configure time Ludovic Courtès
2023-09-20 17:34   ` [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts Maxim Cournoyer
2023-09-11 14:25 ` [bug#65866] [PATCH 7/8] git-download: Use “builtin:git-download” when available Ludovic Courtès
2023-09-20 17:50   ` [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts Maxim Cournoyer
2023-09-22 21:58     ` Ludovic Courtès
2023-09-25 15:56       ` Maxim Cournoyer
2023-09-11 14:25 ` [bug#65866] [PATCH 8/8] tests: Assume ‘git’ is always available Ludovic Courtès
2023-09-20 17:59   ` [bug#65866] [PATCH 0/8] Add built-in builder for Git checkouts Maxim Cournoyer

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://guix.gnu.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=3c42634cb47dd7eaa81a198bc2d097ca74a973ed.1694441831.git.ludo@gnu.org \
    --to=ludo@gnu.org \
    --cc=65866@debbugs.gnu.org \
    --cc=dev@jpoiret.xyz \
    --cc=guix@cbaines.net \
    --cc=ludovic.courtes@inria.fr \
    --cc=me@tobias.gr \
    --cc=othacehe@gnu.org \
    --cc=rekado@elephly.net \
    --cc=zimon.toutoune@gmail.com \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).