Merge branch 'master' into gnome-team

8 files changed, 163 insertions, 32 deletions

diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm
index 0d5493ab90..3f7a2dea27 100644
--- a/guix/build-system/perl.scm
+++ b/guix/build-system/perl.scm
@@ -197,7 +197,9 @@ XS or similar."
                                native-search-paths))
                       #:make-maker? #$make-maker?
                       #:make-maker-flags #$make-maker-flags
-                      #:module-build-flags #$(sexp->gexp module-build-flags)
+                      #:module-build-flags #$(if (pair? module-build-flags)
+                                                 (sexp->gexp module-build-flags)
+                                                 module-build-flags)
                       #:phases #$phases
                       #:build #$build
                       #:system #$system
diff --git a/guix/build/git.scm b/guix/build/git.scm
index 867cade2c4..4c69365a7b 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, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2019, 2023-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -20,7 +20,9 @@
 (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)
+  #:autoload   (guix swh) (%verify-swh-certificate?
+                           swh-download
+                           swh-download-directory-by-nar-hash)
   #:use-module (srfi srfi-34)
   #:use-module (ice-9 format)
   #:export (git-fetch
@@ -91,10 +93,13 @@ fetched, recursively.  Return #t on success, #f otherwise."
 
 (define* (git-fetch-with-fallback url commit directory
                                   #:key (git-command "git")
+                                  hash hash-algorithm
                                   lfs? 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."
+and if that also fails, download from the Software Heritage archive.  When
+HASH and HASH-ALGORITHM are provided, they are interpreted as the nar hash of
+the directory of interested and are used as its content address at SWH."
   (or (git-fetch url commit directory
                  #:lfs? lfs?
                  #:recursive? recursive?
@@ -110,7 +115,14 @@ and if that also fails, download from the Software Heritage archive."
              (format (current-error-port)
                      "Trying to download from Software Heritage...~%")
 
-             (swh-download url commit directory)
+             ;; First try to look up and download the directory corresponding
+             ;; to HASH: this is fundamentally more reliable than looking up
+             ;; COMMIT, especially when COMMIT denotes a tag.
+             (or (and hash hash-algorithm
+                      (swh-download-directory-by-nar-hash hash hash-algorithm
+                                                          directory))
+                 (swh-download url commit directory))
+
              (when (file-exists?
                     (string-append directory "/.gitattributes"))
                ;; Perform CR/LF conversion and other changes
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 3de6ae970d..aadcbd234c 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2021, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2021, 2023-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
@@ -165,6 +165,8 @@ respective documentation."
 
             (git-fetch-with-fallback (getenv "git url") (getenv "git commit")
                                      #$output
+                                     #:hash #$hash
+                                     #:hash-algorithm '#$hash-algo
                                      #:lfs? lfs?
                                      #:recursive? recursive?
                                      #:git-command "git")))))
diff --git a/guix/lint.scm b/guix/lint.scm
index 861e352b93..c95de85e69 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -1658,24 +1658,31 @@ try again later")
     (or (not (request-rate-limit-reached? url method))
         (throw skip-key #t)))
 
+  (define (lookup-by-nar-hash hash)
+    (lookup-directory-by-nar-hash (content-hash-value hash)
+                                  (content-hash-algorithm hash)))
+
   (parameterize ((%allow-request? skip-when-limit-reached))
     (catch #t
       (lambda ()
         (match (package-source package)
           (#f                                     ;no source
            '())
-          ((and (? origin?)
+          ((and (? origin? origin)
                 (= origin-uri (? git-reference? reference)))
            (define url
              (git-reference-url reference))
            (define commit
              (git-reference-commit reference))
-
-           (match (if (commit-id? commit)
-                      (or (lookup-revision commit)
-                          (lookup-origin-revision url commit))
-                      (lookup-origin-revision url commit))
-             ((? revision? revision)
+           (define hash
+             (origin-hash origin))
+
+           (match (or (lookup-by-nar-hash hash)
+                      (if (commit-id? commit)
+                          (or (lookup-revision commit)
+                              (lookup-origin-revision url commit))
+                          (lookup-origin-revision url commit)))
+             ((or (? string?) (? revision?))
               '())
              (#f
               ;; Revision is missing from the archive, attempt to save it.
@@ -1704,9 +1711,10 @@ try again later")
            (if (and=> (origin-hash origin)          ;XXX: for ungoogled-chromium
                       content-hash-value)           ;& icecat
                (let ((hash (origin-hash origin)))
-                 (match (lookup-content (content-hash-value hash)
-                                        (symbol->string
-                                         (content-hash-algorithm hash)))
+                 (match (or (lookup-by-nar-hash hash)
+                            (lookup-content (content-hash-value hash)
+                                            (symbol->string
+                                             (content-hash-algorithm hash))))
                    (#f
                     ;; If SWH doesn't have HASH as is, it may be because it's
                     ;; a hand-crafted tarball.  In that case, check whether
diff --git a/guix/scripts/git/authenticate.scm b/guix/scripts/git/authenticate.scm
index 5f5d423f28..6ff5cee682 100644
--- a/guix/scripts/git/authenticate.scm
+++ b/guix/scripts/git/authenticate.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2024 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -27,6 +27,7 @@
   #:use-module ((guix git) #:select (with-git-error-handling))
   #:use-module (guix progress)
   #:use-module (guix base64)
+  #:autoload   (rnrs bytevectors) (bytevector-length)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
@@ -133,6 +134,16 @@ Authenticate the given Git checkout using COMMIT/SIGNER as its introduction.\n")
   (define commit-short-id
     (compose (cut string-take <> 7) oid->string commit-id))
 
+  (define (openpgp-fingerprint* str)
+    (unless (string-every (char-set-union char-set:hex-digit
+                                          char-set:whitespace)
+                          str)
+      (leave (G_ "~a: invalid OpenPGP fingerprint~%") str))
+    (let ((fingerprint (openpgp-fingerprint str)))
+      (unless (= 20 (bytevector-length fingerprint))
+        (leave (G_ "~a: wrong length for OpenPGP fingerprint~%") str))
+      fingerprint))
+
   (define (make-reporter start-commit end-commit commits)
     (format (current-error-port)
             (G_ "Authenticating commits ~a to ~a (~h new \
@@ -165,7 +176,7 @@ commits)...~%")
                                 (repository-cache-key repository))))
           (define stats
             (authenticate-repository repository (string->oid commit)
-                                     (openpgp-fingerprint signer)
+                                     (openpgp-fingerprint* signer)
                                      #:end end
                                      #:keyring-reference keyring
                                      #:historical-authorizations history
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 9aa0e61e9d..e7eb3b2a1f 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-2018, 2020, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016-2018, 2020, 2023-2024 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -115,6 +115,8 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
       (setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin")
 
       (git-fetch-with-fallback url commit output
+                               #:hash hash
+                               #:hash-algorithm algo
                                #:recursive? recursive?
                                #:git-command %git))))
 
diff --git a/guix/self.scm b/guix/self.scm
index f378548959..19c6d08e01 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -65,6 +65,7 @@
       ("guile-gnutls"       . ,(ref 'tls 'guile-gnutls))
       ("guix-daemon"        . ,(ref 'package-management 'guix-daemon))
       ("disarchive"         . ,(ref 'backup 'disarchive))
+      ("guile-bzip2"        . ,(ref 'guile 'guile-bzip2))
       ("guile-lzma"         . ,(ref 'guile 'guile-lzma))
       ("gzip"               . ,(ref 'compression 'gzip))
       ("bzip2"              . ,(ref 'compression 'bzip2))
@@ -827,6 +828,9 @@ itself."
   (define disarchive
     (specification->package "disarchive"))
 
+  (define guile-bzip2
+    (specification->package "guile-bzip2"))
+
   (define guile-lzma
     (specification->package "guile-lzma"))
 
@@ -1058,6 +1062,7 @@ itself."
                                         #:source source
                                         #:dependencies
                                         (cons* disarchive
+                                               guile-bzip2
                                                guile-lzma
                                                dependencies)
                                         #:guile guile-for-build
diff --git a/guix/swh.scm b/guix/swh.scm
index c7c1c873a2..04cecd854c 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2021, 2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
@@ -78,6 +78,14 @@
             lookup-revision
             lookup-origin-revision
 
+            external-id?
+            external-id-value
+            external-id-type
+            external-id-version
+            external-id-target
+            lookup-external-id
+            lookup-directory-by-nar-hash
+
             content?
             content-checksums
             content-data-url
@@ -115,6 +123,7 @@
             commit-id?
 
             swh-download-directory
+            swh-download-directory-by-nar-hash
             swh-download))
 
 ;;; Commentary:
@@ -382,6 +391,15 @@ FALSE-IF-404? is true, return #f upon 404 responses."
   (permissions   directory-entry-permissions "perms")
   (target-url    directory-entry-target-url "target_url"))
 
+;; <https://archive.softwareheritage.org/api/1/extid/doc/>
+(define-json-mapping <external-id> make-external-id external-id?
+  json->external-id
+  (value         external-id-value "extid")
+  (type          external-id-type "extid_type")
+  (version       external-id-version "extid_version")
+  (target        external-id-target)
+  (target-url    external-id-target-url "target_url"))
+
 ;; <https://archive.softwareheritage.org/api/1/origin/save/>
 (define-json-mapping <save-reply> make-save-reply save-reply?
   json->save-reply
@@ -428,7 +446,7 @@ FALSE-IF-404? is true, return #f upon 404 responses."
   json->revision)
 
 (define-query (lookup-directory id)
-  "Return the directory with the given ID."
+  "Return the list of entries of the directory with the given ID."
   (path "/api/1/directory" id)
   json->directory-entries)
 
@@ -436,6 +454,24 @@ FALSE-IF-404? is true, return #f upon 404 responses."
   (map json->directory-entry
        (vector->list (json->scm port))))
 
+(define (lookup-external-id type id)
+  "Return the external ID record for ID, a bytevector, of the given TYPE
+(currently one of: \"bzr-nodeid\", \"hg-nodeid\", \"nar-sha256\",
+\"checksum-sha512\")."
+  (call (swh-url "/api/1/extid" type
+                 (string-append "hex:" (bytevector->base16-string id)))
+        json->external-id))
+
+(define* (lookup-directory-by-nar-hash hash #:optional (algorithm 'sha256))
+  "Return the SWHID of a directory---i.e., prefixed by \"swh:1:dir\"---for the
+directory that with the given HASH (a bytevector), assuming nar serialization
+and use of ALGORITHM."
+  ;; example:
+  ;; https://archive.softwareheritage.org/api/1/extid/nar-sha256/base64url:0jD6Z4TLMm5g1CviuNNuVNP31KWyoT_oevfr8TQwc3Y/
+  (and=> (lookup-external-id (string-append "nar-" (symbol->string algorithm))
+                             hash)
+         external-id-target))
+
 (define (origin-visits origin)
   "Return the list of visits of ORIGIN, a record as returned by
 'lookup-origin'."
@@ -583,6 +619,41 @@ directory identifier is deprecated."
         json->vault-reply
         http-post*))
 
+(define* (http-get/follow url
+                          #:key
+                          (verify-certificate? (%verify-swh-certificate?)))
+  "Like 'http-get' but follow redirects (HTTP 30x).  On success, return two
+values: an input port to read the response body and its 'Content-Length'.  On
+failure return #f and #f."
+  (define uri
+    (if (string? url) (string->uri url) url))
+
+  (let loop ((uri uri))
+    (define (resolve-uri-reference target)
+      (if (and (uri-scheme target) (uri-host target))
+          target
+          (build-uri (uri-scheme uri) #:host (uri-host uri)
+                     #:port (uri-port uri)
+                     #:path (uri-path target))))
+
+    (let*-values (((response port)
+                   (http-get* uri #:streaming? #t
+                              #:verify-certificate? verify-certificate?))
+                  ((code)
+                   (response-code response)))
+      (case code
+        ((200)
+         (values port (response-content-length response)))
+        ((301                                     ; moved permanently
+          302                                     ; found (redirection)
+          303                                     ; see other
+          307                                     ; temporary redirection
+          308)                                    ; permanent redirection
+         (close-port port)
+         (loop (resolve-uri-reference (response-location response))))
+        (else
+         (values #f #f))))))
+
 (define* (vault-fetch id
                       #:optional kind
                       #:key
@@ -604,16 +675,11 @@ for a tarball containing a bare Git repository corresponding to a revision."
        (match (vault-reply-status reply)
          ('done
           ;; Fetch the bundle.
-          (let-values (((response port)
-                        (http-get* (swh-url (vault-reply-fetch-url reply))
-                                   #:streaming? #t
-                                   #:verify-certificate?
-                                   (%verify-swh-certificate?))))
-            (if (= (response-code response) 200)
-                port
-                (begin                            ;shouldn't happen
-                  (close-port port)
-                  #f))))
+          (let-values (((port length)
+                        (http-get/follow (swh-url (vault-reply-fetch-url reply))
+                                         #:verify-certificate?
+                                         (%verify-swh-certificate?))))
+            port))
          ('failed
           ;; Upon failure, we're supposed to try again.
           (format log-port "SWH vault: failure: ~a~%"
@@ -740,3 +806,26 @@ wait until it becomes available, which could take several minutes."
              "SWH: revision ~s originating from ~a could not be found~%"
              reference url)
      #f)))
+
+(define* (swh-download-directory-by-nar-hash hash algorithm output
+                                             #:key
+                                             (log-port (current-error-port)))
+  "Download from Software Heritage the directory with the given nar HASH for
+ALGORITHM (a symbol such as 'sha256), and unpack it in OUTPUT.  Return #t on
+success and #f on failure.
+
+This procedure uses the \"vault\", which contains \"cooked\" directories in
+the form of tarballs.  If the requested directory is not cooked yet, it will
+wait until it becomes available, which could take several minutes."
+  (match (lookup-directory-by-nar-hash hash algorithm)
+    (#f
+     (format log-port
+             "SWH: directory with nar-~a hash ~a not found~%"
+             algorithm (bytevector->base16-string hash))
+     #f)
+    (swhid
+     (format log-port "SWH: found directory with nar-~a hash ~a at '~a'~%"
+             algorithm (bytevector->base16-string hash) swhid)
+     (swh-download-archive swhid output
+                           #:archive-type 'flat   ;SWHID denotes a directory
+                           #:log-port log-port))))