Merge branch 'master' into gnome-team

9 files changed, 145 insertions, 57 deletions

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 <[email protected]>
+;;; Copyright © 2012-2015, 2018-2019, 2021, 2023 Ludovic Courtès <[email protected]>
 ;;; Copyright © 2021 Lars-Dominik Braun <[email protected]>
 ;;;
 ;;; 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 @@
   #: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 @@
     (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))
 
diff --git a/tests/channels.scm b/tests/channels.scm
index 62312e240c..6c4276deb4 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -50,7 +50,7 @@
   #:use-module (ice-9 match))
 
 (define (gpg+git-available?)
-  (and (which (git-command))
+  (and #t                                         ;'git' is always available
        (which (gpg-command)) (which (gpgconf-command))))
 
 (define commit-id-string
@@ -196,7 +196,6 @@
                                           "abc1234")))
                          instances)))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-channel-instances #:validate-pull"
   'descendant
 
@@ -306,7 +305,6 @@
                (depends? drv3
                          (list drv2 drv0) (list))))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "channel-news, no news"
   '()
   (with-temporary-git-repository directory
@@ -318,7 +316,6 @@
             (latest  (reference-name->oid repository "HEAD")))
         (channel-news-for-commit channel (oid->string latest))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-assert "channel-news, one entry"
   (with-temporary-git-repository directory
       `((add ".guix-channel"
@@ -406,7 +403,6 @@
                          (channel-news-for-commit channel commit5 commit1))
                     '(#f "tag-for-first-news-entry")))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-assert "channel-news, annotated tag"
   (with-temporary-git-repository directory
       `((add ".guix-channel"
@@ -453,7 +449,6 @@
                          (channel-news-for-commit channel commit2))
                     (list commit1)))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-assert "latest-channel-instances, missing introduction for 'guix'"
   (with-temporary-git-repository directory
       '((add "a.txt" "A")
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 66c777cfe7..0e87778981 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -24,10 +24,15 @@
   #: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 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 @@
                    (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,93 @@
                          get-string-all)
                        text))))))
 
+(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)))))
+
+(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))))
+
+(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 '())))
diff --git a/tests/git-authenticate.scm b/tests/git-authenticate.scm
index c063920c12..4de223d422 100644
--- a/tests/git-authenticate.scm
+++ b/tests/git-authenticate.scm
@@ -44,7 +44,6 @@
 
 (test-begin "git-authenticate")
 
-(unless (which (git-command)) (test-skip 1))
 (test-assert "unsigned commits"
   (with-temporary-git-repository directory
       '((add "a.txt" "A")
diff --git a/tests/git.scm b/tests/git.scm
index 9c944d65b1..ad43435b67 100644
--- a/tests/git.scm
+++ b/tests/git.scm
@@ -21,7 +21,6 @@
   #:use-module (git)
   #:use-module (guix git)
   #:use-module (guix tests git)
-  #:use-module (guix build utils)
   #:use-module ((guix utils) #:select (call-with-temporary-directory))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
@@ -33,8 +32,6 @@
 
 (test-begin "git")
 
-;; 'with-temporary-git-repository' relies on the 'git' command.
-(unless (which (git-command)) (test-skip 1))
 (test-assert "commit-difference, linear history"
   (with-temporary-git-repository directory
       '((add "a.txt" "A")
@@ -61,7 +58,6 @@
              ;; empty list.
              (null? (commit-difference commit1 commit4)))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-assert "commit-difference, fork"
   (with-temporary-git-repository directory
       '((add "a.txt" "A")
@@ -101,7 +97,6 @@
              (lset= eq? (commit-difference master4 master2)
                     (list master4 merge master3 devel1 devel2)))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-assert "commit-difference, excluded commits"
   (with-temporary-git-repository directory
       '((add "a.txt" "A")
@@ -126,7 +121,6 @@
                     (list commit4))
              (null? (commit-difference commit4 commit1 (list commit5))))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "commit-relation"
   '(self                                          ;master3 master3
     ancestor                                      ;master1 master3
@@ -166,7 +160,6 @@
               (commit-relation master1 merge)
               (commit-relation merge master1))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "commit-descendant?"
   '((master3 master3 => #t)
     (master1 master3 => #f)
@@ -216,7 +209,6 @@
                   (master1 merge)
                   (merge master1)))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "remote-refs"
   '("refs/heads/develop" "refs/heads/master"
     "refs/tags/v1.0" "refs/tags/v1.1")
@@ -231,7 +223,6 @@
         (tag "v1.1" "release-1.1"))
     (remote-refs directory)))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "remote-refs: only tags"
  '("refs/tags/v1.0" "refs/tags/v1.1")
   (with-temporary-git-repository directory
@@ -243,7 +234,6 @@
         (tag "v1.1" "Release 1.1"))
     (remote-refs directory #:tags? #t)))
 
-(unless (which (git-command)) (test-skip 1))
 (test-assert "update-cached-checkout, tag"
   (call-with-temporary-directory
    (lambda (cache)
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 61ae295b96..6fde1eb8b1 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -25,6 +25,7 @@
   #:use-module (guix utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
+  #:use-module ((web client) #:select (current-http-proxy))
   #:use-module (ice-9 match))
 
 (test-begin "gnu-maintenance")
@@ -157,9 +158,9 @@ submodules/qtbase-everywhere-src-6.5.2.tar.xz"
 submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
 
 (test-equal "rewrite-url, without to-version"
-  "https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz"
+  "http://dist.libuv.example.org/dist/v1.46.0/libuv-v1.46.0.tar.gz"
   (with-http-server
-      ;; First reply, crawling https://dist.libuv.org/dist/.
+      ;; First reply, crawling http://dist.libuv.example.org/dist/.
       `((200 "\
 <!DOCTYPE html>
 <html>
@@ -173,7 +174,7 @@ submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
 <a href=\"v1.46.0/\" title=\"v1.46.0/\">v1.46.0/</a>
 </body>
 </html>")
-        ;; Second reply, crawling https://dist.libuv.org/dist/v1.46.0/.
+        ;; Second reply, crawling http://dist.libuv.example.org/dist/v1.46.0/.
         (200 "\
 <!DOCTYPE html>
 <html>
@@ -190,7 +191,8 @@ submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
    libuv-v1.46.0.tar.gz.sign</a>
 </body>
 </html>"))
-    (rewrite-url "https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz"
-                 "1.45.0")))
+    (parameterize ((current-http-proxy (%local-url)))
+      (rewrite-url "http://dist.libuv.example.org/dist/v1.45.0/libuv-v1.45.0.tar.gz"
+                   "1.45.0"))))
 
 (test-end)
diff --git a/tests/guix-graph.sh b/tests/guix-graph.sh
index 37ea0a7b8c..b9e20dac81 100644
--- a/tests/guix-graph.sh
+++ b/tests/guix-graph.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2015-2016, 2019-2020, 2022 Ludovic Courtès <[email protected]>
+# Copyright © 2015-2016, 2019-2020, 2022-2023 Ludovic Courtès <[email protected]>
 # Copyright © 2019 Simon Tournier <[email protected]>
 #
 # This file is part of GNU Guix.
@@ -86,8 +86,8 @@ guix graph --path emacs vim && false
 
 path="\
 emacs
-gnutls
-p11-kit
+cairo
+gobject-introspection
 libffi"
 test "`guix graph --path emacs libffi | cut -d '@' -f1`" = "$path"
 
diff --git a/tests/import-git.scm b/tests/import-git.scm
index f1bce154bb..20255dedb3 100644
--- a/tests/import-git.scm
+++ b/tests/import-git.scm
@@ -24,7 +24,6 @@
   #:use-module (guix import git)
   #:use-module (guix git-download)
   #:use-module (guix tests git)
-  #:use-module (guix build utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64))
 
@@ -46,7 +45,6 @@
         (base32
          "0000000000000000000000000000000000000000000000000000"))))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: no custom prefix, suffix, and delimiter"
   "1.0.1"
   (with-temporary-git-repository directory
@@ -56,7 +54,6 @@
     (let ((package (make-package directory "1.0.0")))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: custom prefix, no suffix and delimiter"
   "1.0.1"
   (with-temporary-git-repository directory
@@ -67,7 +64,6 @@
                                  '((release-tag-prefix . "prefix-")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: custom suffix, no prefix and delimiter"
   "1.0.1"
   (with-temporary-git-repository directory
@@ -78,7 +74,6 @@
                                  '((release-tag-suffix . "-suffix-[0-9]*")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: custom delimiter, no prefix and suffix"
   "2021.09.07"
   (with-temporary-git-repository directory
@@ -89,7 +84,6 @@
                                  '((release-tag-version-delimiter . "-")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: empty delimiter, no prefix and suffix"
   "20210907"
   (with-temporary-git-repository directory
@@ -100,7 +94,6 @@
                                  '((release-tag-version-delimiter . "")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: custom prefix and suffix, no delimiter"
   "2.0.0"
   (with-temporary-git-repository directory
@@ -112,7 +105,6 @@
                                    (release-tag-suffix . "suffix-[0-9]")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: custom prefix, suffix, and delimiter"
   "2.0.0"
   (with-temporary-git-repository directory
@@ -125,7 +117,6 @@
                                    (release-tag-version-delimiter . "_")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: only pre-releases available"
   #f
   (with-temporary-git-repository directory
@@ -135,7 +126,6 @@
     (let ((package (make-package directory "1.0.0")))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: accept pre-releases"
   "2.0.0-rc1"
   (with-temporary-git-repository directory
@@ -146,7 +136,6 @@
                                  '((accept-pre-releases? . #t)))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: accept pre-releases, and custom prefix"
   "2.0.0-rc1"
   (with-temporary-git-repository directory
@@ -158,7 +147,6 @@
                                    (release-tag-prefix . "version-")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: accept pre-releases, and custom suffix"
   "2.0.0-rc1"
   (with-temporary-git-repository directory
@@ -170,7 +158,6 @@
                                    (release-tag-suffix . "-suffix")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: accept pre-releases, delimiter conflicts with pre-release part"
   "2.0.0_alpha"
   (with-temporary-git-repository directory
@@ -182,7 +169,6 @@
                                    (release-tag-version-delimiter . "_")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: accept pre-releases, and custom suffix and prefix"
   "2.0.0-alpha"
   (with-temporary-git-repository directory
@@ -195,7 +181,6 @@
                                    (release-tag-suffix . "-suffix")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: accept pre-releases, and custom suffix, prefix, and delimiter"
   "2.0.0-alpha"
   (with-temporary-git-repository directory
@@ -209,7 +194,6 @@
                                    (release-tag-version-delimiter . "-")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: accept pre-releases, no delimiter, and custom suffix, prefix"
   "2alpha"
   (with-temporary-git-repository directory
@@ -223,7 +207,6 @@
                                    (release-tag-version-delimiter . "")))))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: no tags found"
   #f
   (with-temporary-git-repository directory
@@ -232,7 +215,6 @@
     (let ((package (make-package directory "1.0.0")))
       (latest-git-tag-version package))))
 
-(unless (which (git-command)) (test-skip 1))
 (test-equal "latest-git-tag-version: no valid tags found"
   #f
   (with-temporary-git-repository directory
diff --git a/tests/read-print.scm b/tests/read-print.scm
index 9e1d8038f1..c8b8eb73fe 100644
--- a/tests/read-print.scm
+++ b/tests/read-print.scm
@@ -258,13 +258,13 @@ mnopqrstuvwxyz.\")"
 
 (test-pretty-print "\
 (package
-  ;; Here 'sha256', 'base32', and 'arguments' must be
+  ;; Here 'source', 'sha256', and 'arguments' must be
   ;; immediately followed by a newline.
-  (source (origin
-            (method url-fetch)
-            (sha256
-             (base32
-              \"not a real base32 string\"))))
+  (source
+   (origin
+     (method url-fetch)
+     (sha256
+      (base32 \"not a real base32 string\"))))
   (arguments
    '(#:phases %standard-phases
      #:tests? #f)))")
@@ -274,12 +274,13 @@ mnopqrstuvwxyz.\")"
 (package
   (name \"keyword-value-same-line\")
   (arguments
-   (list #:phases #~(modify-phases %standard-phases
-                      (add-before 'x 'y
-                        (lambda* (#:key inputs #:allow-other-keys)
-                          (foo bar baz))))
-         #:make-flags #~'(\"ANSWER=42\")
-         #:tests? #f)))")
+   (list
+    #:phases #~(modify-phases %standard-phases
+                 (add-before 'x 'y
+                   (lambda* (#:key inputs #:allow-other-keys)
+                     (foo bar baz))))
+    #:make-flags #~'(\"ANSWER=42\")
+    #:tests? #f)))")
 
 (test-pretty-print "\
 (let ((x 1)