02/02: build-package-metadata: Include content-addressed URLs for tarballs.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository maintenance.

commit b7af47ceb629b2267ea8c28dbe5750a456be0b8f
Author: Ludovic Courtès <ludovic.courtes@inria.fr>
AuthorDate: Tue Apr 25 14:43:31 2023 +0200

    build-package-metadata: Include content-addressed URLs for tarballs.
    
    Suggested by Simon Tournier <zimon.toutoune@gmail.com> in
    <https://lists.gnu.org/archive/html/guix-devel/2023-04/msg00029.html>.
    
    * hydra/build-package-metadata.scm (%content-addressed-mirrors): New 
variable.
    (origin->json)[resolve]: Add 'hash' parameter; when true, add a list of
    content-addressed URLs.
    Update caller.
---
 hydra/build-package-metadata.scm | 40 +++++++++++++++++++++++++++++++++++-----
 1 file changed, 35 insertions(+), 5 deletions(-)

diff --git a/hydra/build-package-metadata.scm b/hydra/build-package-metadata.scm
index 6fa2173..1ddb409 100755
--- a/hydra/build-package-metadata.scm
+++ b/hydra/build-package-metadata.scm
@@ -30,6 +30,7 @@
              (guix utils)
              (guix gexp)
              ((guix build download) #:select (maybe-expand-mirrors))
+             ((guix base32) #:select (bytevector->nix-base32-string))
              ((guix base64) #:select (base64-encode))
              ((guix describe) #:select (current-profile))
              ((guix config) #:select (%guix-version))
@@ -73,6 +74,27 @@ superseded packages."
 ;;; Required by 'origin->json' for 'computed-origin-method' corner cases
 (define gexp-references (@@ (guix gexp) gexp-references))
 
+(define %content-addressed-mirrors
+  ;; List of content-addressed mirrors.
+  ;; XXX: somewhat duplicated from (guix download)
+  (let ((guix-publish
+         (lambda (host)
+           (lambda (file hash)
+             ;; Files served by 'guix publish'.
+             (string-append "https://"; host "/file/"
+                            file "/" (symbol->string
+                                      (content-hash-algorithm hash))
+                            "/" (bytevector->nix-base32-string
+                                 (content-hash-value hash)))))))
+
+    (list (guix-publish "bordeaux.guix.gnu.org")
+          (guix-publish "ci.guix.gnu.org")
+          (lambda (file hash)
+            (string-append "https://tarballs.nixos.org/";
+                           (symbol->string (content-hash-algorithm hash))
+                           "/" (bytevector->nix-base32-string
+                                (content-hash-value hash)))))))
+
 (define (origin->json origin)
   "Return a list of JSON representations (an alist) of ORIGIN."
   (define method
@@ -81,10 +103,17 @@ superseded packages."
   (define uri
     (origin-uri origin))
 
-  (define (resolve urls)
-    (map uri->string
-         (append-map (cut maybe-expand-mirrors <> %mirrors)
-                     (map string->uri urls))))
+  (define (resolve urls hash)
+    (append (map uri->string
+                 (append-map (cut maybe-expand-mirrors <> %mirrors)
+                             (map string->uri urls)))
+            (if hash
+                (let ((file (origin-actual-file-name origin))
+                      (hash (origin-hash origin)))
+                  (map (lambda (make-url)
+                         (make-url file hash))
+                       %content-addressed-mirrors))
+                '())))
 
   (if (eq? method (@@ (guix packages) computed-origin-method))
       ;; Packages in gnu/packages/gnuzilla.scm and gnu/packages/linux.scm
@@ -118,7 +147,8 @@ superseded packages."
                                 (resolve
                                  (match uri
                                    ((? string? url) (list url))
-                                   ((urls ...) urls)))))))
+                                   ((urls ...) urls))
+                                 (origin-hash origin))))))
                  ((eq? git-fetch method)
                   `(("git_url" . ,(git-reference-url uri))))
                  ((eq? svn-fetch method)