Subject: [bug#50515] [PATCH v2 2/2] website: Add 'computed-origin-method' packages to 'sources.json'.

From: zimoun <[email-masked]>
Date: Tue, 5 Oct 2021 16:09:37 +0200

With Guix 9875f9bca3976bf3576eab9be42164fde454597e, the packages considered
are IceCat and the Linux kernel; see: gnu/packages/gnuzilla.scm and
gnu/packages/linux.scm.

* website/apps/packages/builder.scm (gexp-references): Unexported procedure
from the module '(guix gexp)'.
(origin->json): Add 'computed-origin-method' case.
(package-json-builder): Adjust.
(sources-json-builder): Idem.
[flatten]: New procedure.
---
 website/apps/packages/builder.scm | 141 +++++++++++++++++++-----------
 1 file changed, 89 insertions(+), 52 deletions(-)

diff --git a/website/apps/packages/builder.scm b/website/apps/packages/builder.scm
index fb53215..9237d89 100644
--- a/website/apps/packages/builder.scm
+++ b/website/apps/packages/builder.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2017 Ludovic Courtès <[email-masked]>
 ;;; Copyright © 2019 Ricardo Wurmus <[email-masked]>
 ;;; Copyright © 2019 Nicolò Balzarotti <[email-masked]>
-;;; Copyright © 2020 Simon Tournier <[email-masked]>
+;;; Copyright © 2020, 2021 Simon Tournier <[email-masked]>
 ;;;
 ;;; Initially written by sirgazil
 ;;; who waives all copyright interest on this file.
@@ -49,11 +49,14 @@
   #:use-module ((guix base64) #:select (base64-encode))
   #:use-module ((guix describe) #:select (current-profile))
   #:use-module ((guix config) #:select (%guix-version))
+  #:use-module (guix gexp)
   #:use-module (json)
   #:use-module (ice-9 match)
   #:use-module ((web uri) #:select (string->uri uri->string))
   #:export (builder))
 
+;;; Required by 'origin->json' for 'computed-origin-method' corner cases
+(define gexp-references (@@ (guix gexp) gexp-references))
 
 ;;;
 ;;; Application builder.
@@ -98,7 +101,7 @@
   (define method
     (origin-method origin))
 
-  (define uri                                     ;represented as string
+  (define uri
     (origin-uri origin))
 
   (define (resolve urls)
@@ -106,53 +109,70 @@
          (append-map (cut maybe-expand-mirrors <> %mirrors)
                      (map string->uri urls))))
 
-  `((type . ,(cond ((or (eq? url-fetch method)
-                        (eq? url-fetch/tarbomb method)
-                        (eq? url-fetch/zipbomb method)) 'url)
-                   ((eq? git-fetch method) 'git)
-                   ((or (eq? svn-fetch method)
-                        (eq? svn-multi-fetch method)) 'svn)
-                   ((eq? hg-fetch method) 'hg)
-                   (else                   #nil)))
-    ,@(cond ((or (eq? url-fetch method)
-                 (eq? url-fetch/tarbomb method)
-                 (eq? url-fetch/zipbomb method))
-             `(("urls" . ,(list->vector
-                           (resolve
-                            (match uri
-                              ((? string? url) (list url))
-                              ((urls ...) urls)))))))
-            ((eq? git-fetch method)
-             `(("git_url" . ,(git-reference-url uri))))
-            ((eq? svn-fetch method)
-             `(("svn_url" . ,(svn-reference-url uri))))
-            ((eq? svn-multi-fetch method)
-             `(("svn_url" . ,(svn-multi-reference-url uri))))
-            ((eq? hg-fetch method)
-             `(("hg_url" . ,(hg-reference-url uri))))
-            (else '()))
-    ,@(if (or (eq? url-fetch method)
-              (eq? url-fetch/tarbomb method)
-              (eq? url-fetch/zipbomb method))
-          (let* ((content-hash (origin-hash origin))
-                 (hash-value (content-hash-value content-hash))
-                 (hash-algorithm (content-hash-algorithm content-hash))
-                 (algorithm-string (symbol->string hash-algorithm)))
-            `(("integrity" . ,(string-append algorithm-string "-"
-                                             (base64-encode hash-value)))))
-          '())
-    ,@(if (eq? method git-fetch)
-          `(("git_ref" . ,(git-reference-commit uri)))
-          '())
-    ,@(if (eq? method svn-fetch)
-          `(("svn_revision" . ,(svn-reference-revision uri)))
-          '())
-    ,@(if (eq? method svn-multi-fetch)
-          `(("svn_revision" . ,(svn-multi-reference-revision uri)))
-          '())
-    ,@(if (eq? method hg-fetch)
-          `(("hg_changeset" . ,(hg-reference-changeset uri)))
-          '())))
+  (if (eq? method (@@ (guix packages) computed-origin-method))
+      ;; Packages in gnu/packages/gnuzilla.scm and gnu/packages/linux.scm
+      ;; represent their 'uri' as 'promise'.
+      (match uri
+        ((? promise? promise)
+         (match (force promise)
+           ((? gexp? g)
+            (map origin->json
+                 (filter-map (match-lambda
+                               ((? gexp-input? thing)
+                                (match (gexp-input-thing thing)
+                                  ((? origin? o) o)
+                                  (_ #f)))
+                               (_ #f))
+                             (gexp-references g))))
+           (_ `((type . #nil))))))
+      ;;Regular packages represent 'uri' as string.
+      `((type . ,(cond ((or (eq? url-fetch method)
+                            (eq? url-fetch/tarbomb method)
+                            (eq? url-fetch/zipbomb method)) 'url)
+                       ((eq? git-fetch method) 'git)
+                       ((or (eq? svn-fetch method)
+                            (eq? svn-multi-fetch method)) 'svn)
+                       ((eq? hg-fetch method) 'hg)
+                       (else                   #nil)))
+        ,@(cond ((or (eq? url-fetch method)
+                     (eq? url-fetch/tarbomb method)
+                     (eq? url-fetch/zipbomb method))
+                 `(("urls" . ,(list->vector
+                               (resolve
+                                (match uri
+                                  ((? string? url) (list url))
+                                  ((urls ...) urls)))))))
+                ((eq? git-fetch method)
+                 `(("git_url" . ,(git-reference-url uri))))
+                ((eq? svn-fetch method)
+                 `(("svn_url" . ,(svn-reference-url uri))))
+                ((eq? svn-multi-fetch method)
+                 `(("svn_url" . ,(svn-multi-reference-url uri))))
+                ((eq? hg-fetch method)
+                 `(("hg_url" . ,(hg-reference-url uri))))
+                (else '()))
+        ,@(if (or (eq? url-fetch method)
+                  (eq? url-fetch/tarbomb method)
+                  (eq? url-fetch/zipbomb method))
+              (let* ((content-hash (origin-hash origin))
+                     (hash-value (content-hash-value content-hash))
+                     (hash-algorithm (content-hash-algorithm content-hash))
+                     (algorithm-string (symbol->string hash-algorithm)))
+                `(("integrity" . ,(string-append algorithm-string "-"
+                                                 (base64-encode hash-value)))))
+              '())
+        ,@(if (eq? method git-fetch)
+              `(("git_ref" . ,(git-reference-commit uri)))
+              '())
+        ,@(if (eq? method svn-fetch)
+              `(("svn_revision" . ,(svn-reference-revision uri)))
+              '())
+        ,@(if (eq? method svn-multi-fetch)
+              `(("svn_revision" . ,(svn-multi-reference-revision uri)))
+              '())
+        ,@(if (eq? method hg-fetch)
+              `(("hg_changeset" . ,(hg-reference-changeset uri)))
+              '()))))
 
 (define (packages-json-builder)
   "Return a JSON page listing all packages."
@@ -167,7 +187,12 @@
       ,@(if cpe-name `(("cpe_name" . ,cpe-name)) '())
       ,@(if cpe-version `(("cpe_version" . ,cpe-version)) '())
       ,@(if (origin? (package-source package))
-            `(("source" . ,(origin->json (package-source package))))
+            `(("source" . ,(let ((json (origin->json (package-source package))))
+                             (match json
+                               ((('type . x) other ...)
+                                json)
+                               ((head tail ...) ;multi-origin
+                                head)))))       ;XXXX: Improve this approximation
             '())
       ("synopsis" . ,(package-synopsis package))
       ,@(if (package-home-page package)
@@ -195,11 +220,23 @@
   (define (package->json package)
     `(,@(if (origin? (package-source package))
             (origin->json (package-source package))
-            `(("type" . "no-origin")
+            `((type . "no-origin")
               ("name" . ,(package-name package))))))
 
+  (define (flatten lst)
+    ;; Convert nested lists to simple list
+    `(,@(if (null? lst)
+            '()
+            (match lst
+              ((head tail ...)
+               (match head
+                 ((('type . x) other ...)
+                  (cons head (flatten tail)))
+                 (_
+                  (append (flatten head) (flatten tail)))))))))
+
   (make-page "sources.json"
-             `(("sources" . ,(list->vector (map package->json (all-packages))))
+             `(("sources" . ,(list->vector (flatten (map package->json (all-packages)))))
                ("version" . "1")
                ("revision" .
                 ,(match (current-profile)
-- 
2.29.2