Merge branch 'master' into gnome-team

8 files changed, 188 insertions, 80 deletions

diff --git a/guix/build/git.scm b/guix/build/git.scm
index deda10fee8..0ff263c81b 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2019, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,9 +18,12 @@
 
 (define-module (guix build git)
   #:use-module (guix build utils)
+  #:autoload   (guix build download-nar) (download-nar)
+  #:autoload   (guix swh) (%verify-swh-certificate? swh-download)
   #:use-module (srfi srfi-34)
   #:use-module (ice-9 format)
-  #:export (git-fetch))
+  #:export (git-fetch
+            git-fetch-with-fallback))
 
 ;;; Commentary:
 ;;;
@@ -76,4 +79,41 @@ recursively.  Return #t on success, #f otherwise."
       (delete-file-recursively ".git")
       #t)))
 
+
+(define* (git-fetch-with-fallback url commit directory
+                                  #:key (git-command "git") recursive?)
+  "Like 'git-fetch', fetch COMMIT from URL into DIRECTORY, but fall back to
+alternative methods when fetching from URL fails: attempt to download a nar,
+and if that also fails, download from the Software Heritage archive."
+  (or (git-fetch url commit directory
+                 #:recursive? recursive?
+                 #:git-command git-command)
+      (download-nar directory)
+
+      ;; As a last resort, attempt to download from Software Heritage.
+      ;; Disable X.509 certificate verification to avoid depending
+      ;; on nss-certs--we're authenticating the checkout anyway.
+      ;; XXX: Currently recursive checkouts are not supported.
+      (and (not recursive?)
+           (parameterize ((%verify-swh-certificate? #f))
+             (format (current-error-port)
+                     "Trying to download from Software Heritage...~%")
+
+             (swh-download url commit directory)
+             (when (file-exists?
+                    (string-append directory "/.gitattributes"))
+               ;; Perform CR/LF conversion and other changes
+               ;; specificied by '.gitattributes'.
+               (invoke git-command "-C" directory "init")
+               (invoke git-command "-C" directory "config" "--local"
+                       "user.email" "you@example.org")
+               (invoke git-command "-C" directory "config" "--local"
+                       "user.name" "Your Name")
+               (invoke git-command "-C" directory "add" ".")
+               (invoke git-command "-C" directory "commit" "-am" "init")
+               (invoke git-command "-C" directory "read-tree" "--empty")
+               (invoke git-command "-C" directory "reset" "--hard")
+               (delete-file-recursively
+                (string-append directory "/.git")))))))
+
 ;;; git.scm ends here
diff --git a/guix/config.scm.in b/guix/config.scm.in
index d582d91d74..62e15dd713 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2016, 2018-2019, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -35,6 +35,7 @@
             %config-directory
 
             %system
+            %git
             %gzip
             %bzip2
             %xz))
@@ -109,6 +110,9 @@
 (define %system
   "@guix_system@")
 
+(define %git
+  "@GIT@")
+
 (define %gzip
   "@GZIP@")
 
diff --git a/guix/git-download.scm b/guix/git-download.scm
index d88f4c40ee..5d5d73dc6b 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -27,7 +27,9 @@
   #: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!)
   #:autoload   (git repository) (repository-open
                                  repository-close!
@@ -77,15 +79,19 @@
   (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.
@@ -116,19 +122,16 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
   (define modules
     (delete '(guix config)
             (source-module-closure '((guix build git)
-                                     (guix build utils)
-                                     (guix build download-nar)
-                                     (guix swh)))))
+                                     (guix build utils)))))
 
   (define build
     (with-imported-modules modules
-      (with-extensions (list guile-json gnutls   ;for (guix swh)
+      (with-extensions (list guile-json gnutls    ;for (guix swh)
                              guile-lzlib)
         #~(begin
             (use-modules (guix build git)
-                         (guix build utils)
-                         (guix build download-nar)
-                         (guix swh)
+                         ((guix build utils)
+                          #:select (set-path-environment-variable))
                          (ice-9 match))
 
             (define recursive?
@@ -151,40 +154,13 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
             (setvbuf (current-output-port) 'line)
             (setvbuf (current-error-port) 'line)
 
-            (or (git-fetch (getenv "git url") (getenv "git commit")
-                           #$output
-                           #:recursive? recursive?
-                           #:git-command "git")
-                (download-nar #$output)
-
-                ;; As a last resort, attempt to download from Software Heritage.
-                ;; Disable X.509 certificate verification to avoid depending
-                ;; on nss-certs--we're authenticating the checkout anyway.
-                ;; XXX: Currently recursive checkouts are not supported.
-                (and (not recursive?)
-                     (parameterize ((%verify-swh-certificate? #f))
-                       (format (current-error-port)
-                               "Trying to download from Software Heritage...~%")
-
-                       (swh-download (getenv "git url") (getenv "git commit")
-                                     #$output)
-                       (when (file-exists?
-                              (string-append #$output "/.gitattributes"))
-                         ;; Perform CR/LF conversion and other changes
-                         ;; specificied by '.gitattributes'.
-                         (invoke "git" "-C" #$output "init")
-                         (invoke "git" "-C" #$output "config" "--local"
-                                 "user.email" "you@example.org")
-                         (invoke "git" "-C" #$output "config" "--local"
-                                 "user.name" "Your Name")
-                         (invoke "git" "-C" #$output "add" ".")
-                         (invoke "git" "-C" #$output "commit" "-am" "init")
-                         (invoke "git" "-C" #$output "read-tree" "--empty")
-                         (invoke "git" "-C" #$output "reset" "--hard")
-                         (delete-file-recursively
-                          (string-append #$output "/.git"))))))))))
-
-  (mlet %store-monad ((guile (package->derivation guile system)))
+            (git-fetch-with-fallback (getenv "git url") (getenv "git commit")
+                                     #$output
+                                     #:recursive? recursive?
+                                     #:git-command "git")))))
+
+  (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
@@ -192,7 +168,11 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
                       ;; downloads.
                       #:script-name "git-download"
                       #:env-vars
-                      `(("git url" . ,(git-reference-url ref))
+                      `(("git url" . ,(match (%download-fallback-test)
+                                        ('content-addressed-mirrors
+                                         "https://example.org/does-not-exist")
+                                        (_
+                                         (git-reference-url ref))))
                         ("git commit" . ,(git-reference-commit ref))
                         ("git recursive?" . ,(object->string
                                               (git-reference-recursive? ref))))
@@ -207,6 +187,54 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
                       #: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.
diff --git a/guix/git.scm b/guix/git.scm
index 1b3355109e..b7182305cf 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -364,7 +364,8 @@ definitely available in REPOSITORY, false otherwise."
   (match ref
     (('commit . (? commit-id? commit))
      (let ((oid (string->oid commit)))
-       (->bool (commit-lookup repository oid))))
+       (false-if-git-not-found
+        (->bool (commit-lookup repository oid)))))
     ((or ('tag . str)
          ('tag-or-commit . str))
      (false-if-git-not-found
diff --git a/guix/read-print.scm b/guix/read-print.scm
index 25be289d60..7faad82c94 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -359,10 +359,11 @@ expressions and blanks that were read."
   ;; the context in which they must appear.  This is similar to a special form
   ;; of 1, except that indent is 1 instead of 2 columns.
   (vhashq
-   ('arguments '(package))
-   ('sha256 '(origin source package))
-   ('base32 '(sha256 origin))
+   ('source '(package))
    ('git-reference '(uri origin source))
+   ('sha256 '(origin source package))
+   ('arguments '(package))
+   ('list '(arguments package))
    ('search-paths '(package))
    ('native-search-paths '(package))
    ('search-path-specification '())
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index a7ff1593a6..e32f22ec99 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -123,8 +123,7 @@ Export/import one or more packages from/to the store.\n"))
                    (exit 0)))
          (option '(#\V "version") #f #f
                  (lambda args
-                   (show-version-and-exit "guix build")))
-
+                   (show-version-and-exit "guix archive")))
          (option '("export") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'export #t result)))
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 6889bcef79..045dd84ad6 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,9 @@
   #: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)
+  #:autoload   (guix config) (%git)
   #:use-module (ice-9 match)
   #:export (guix-perform-download))
 
@@ -42,16 +44,14 @@
     (module-use! module (resolve-interface '(guix base32)))
     module))
 
-(define* (perform-download drv #:optional output
+(define* (perform-download drv 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."
+Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
+'bmRepair' builds."
   (derivation-let drv ((url "url")
-                       (output* "out")
                        (executable "executable")
                        (mirrors "mirrors")
                        (content-addressed-mirrors "content-addressed-mirrors")
@@ -59,15 +59,10 @@ actual output is different from that when we're doing a 'bmCheck' or
     (unless url
       (leave (G_ "~a: missing URL~%") (derivation-file-name drv)))
 
-    (let* ((output     (or output output*))
-           (url        (call-with-input-string url read))
+    (let* ((url        (call-with-input-string url read))
            (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 +87,31 @@ actual output is different from that when we're doing a 'bmCheck' or
         (when (and executable (string=? executable "1"))
           (chmod output #o755))))))
 
+(define* (perform-git-download drv output
+                               #:key print-build-trace?)
+  "Perform the download described by DRV, a fixed-output derivation, to
+OUTPUT.
+
+Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
+'bmRepair' builds."
+  (derivation-let drv ((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* ((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?
+                               #:git-command %git))))
+
 (define (assert-low-privileges)
   (when (zero? (getuid))
     (leave (G_ "refusing to run with elevated privileges (UID ~a)~%")
@@ -120,13 +140,20 @@ actual output is different from that when we're doing a 'bmCheck' or
     (match args
       (((? derivation-path? drv) (? store-path? output))
        (assert-low-privileges)
-       (perform-download (read-derivation-from-file drv)
-                         output
-                         #:print-build-trace? print-build-trace?))
-      (((? derivation-path? drv))                 ;backward compatibility
-       (assert-low-privileges)
-       (perform-download (read-derivation-from-file drv)
-                         #: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/guix/self.scm b/guix/self.scm
index b8b9b9fe37..a1f235659d 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -69,6 +69,7 @@
       ("gzip"               . ,(ref 'compression 'gzip))
       ("bzip2"              . ,(ref 'compression 'bzip2))
       ("xz"                 . ,(ref 'compression 'xz))
+      ("git-minimal"        . ,(ref 'version-control 'git-minimal))
       ("po4a"               . ,(ref 'gettext 'po4a))
       ("gettext-minimal"    . ,(ref 'gettext 'gettext-minimal))
       ("gcc-toolchain"      . ,(ref 'commencement 'gcc-toolchain))
@@ -826,6 +827,9 @@ itself."
   (define guile-lzma
     (specification->package "guile-lzma"))
 
+  (define git
+    (specification->package "git-minimal"))
+
   (define dependencies
     (append-map transitive-package-dependencies
                 (list guile-gcrypt guile-gnutls guile-git guile-avahi
@@ -999,6 +1003,7 @@ itself."
                     => ,(make-config.scm #:gzip gzip
                                          #:bzip2 bzip2
                                          #:xz xz
+                                         #:git git
                                          #:package-name
                                          %guix-package-name
                                          #:package-version
@@ -1104,7 +1109,7 @@ itself."
     (%storedir . "/gnu/store")
     (%sysconfdir . "/etc")))
 
-(define* (make-config.scm #:key gzip xz bzip2
+(define* (make-config.scm #:key gzip xz bzip2 git
                           (package-name "GNU Guix")
                           (package-version "0")
                           (channel-metadata #f)
@@ -1134,6 +1139,7 @@ itself."
                                %state-directory
                                %store-database-directory
                                %config-directory
+                               %git
                                %gzip
                                %bzip2
                                %xz))
@@ -1176,6 +1182,8 @@ itself."
                      ;; information is used by (guix describe).
                      '#$channel-metadata)
 
+                   (define %git
+                     #+(and git (file-append git "/bin/git")))
                    (define %gzip
                      #+(and gzip (file-append gzip "/bin/gzip")))
                    (define %bzip2