[bug#50515] (guix-artwork)[PATCH 0/2] List linux origins in 'sources.json'.

[bug#50515] (guix-artwork)[PATCH 0/2] List linux origins in 'sources.json'.

[zimoun]

Hi,

This patch is a follow-up of this message:

<https://lists.gnu.org/archive/html/guix-devel/2021-09/msg00106.html>

Now, 'sources.json' file contains the missing origins; for instance:

--8<---------------cut here---------------start------------->8---
$ cat /tmp/gnu.org/software/guix/sources.json | jq | grep fsfla | sort | uniq -c
      4         "https://linux-libre.fsfla.org/pub/linux-libre/releases/4.14.238-gnu/deblob-4.14"
      4         "https://linux-libre.fsfla.org/pub/linux-libre/releases/4.14.238-gnu/deblob-check"
      4         "https://linux-libre.fsfla.org/pub/linux-libre/releases/4.19.196-gnu/deblob-4.19"
      4         "https://linux-libre.fsfla.org/pub/linux-libre/releases/4.19.196-gnu/deblob-check"
      2         "https://linux-libre.fsfla.org/pub/linux-libre/releases/4.4.274-gnu/deblob-4.4"
      2         "https://linux-libre.fsfla.org/pub/linux-libre/releases/4.4.274-gnu/deblob-check"
      2         "https://linux-libre.fsfla.org/pub/linux-libre/releases/4.9.274-gnu/deblob-4.9"
      2         "https://linux-libre.fsfla.org/pub/linux-libre/releases/4.9.274-gnu/deblob-check"
      4         "https://linux-libre.fsfla.org/pub/linux-libre/releases/5.10.47-gnu/deblob-5.10"
      4         "https://linux-libre.fsfla.org/pub/linux-libre/releases/5.10.47-gnu/deblob-check"
     14         "https://linux-libre.fsfla.org/pub/linux-libre/releases/5.12.14-gnu/deblob-5.12"
     14         "https://linux-libre.fsfla.org/pub/linux-libre/releases/5.12.14-gnu/deblob-check"
      4         "https://linux-libre.fsfla.org/pub/linux-libre/releases/5.4.129-gnu/deblob-5.4"
      4         "https://linux-libre.fsfla.org/pub/linux-libre/releases/5.4.129-gnu/deblob-check"
      2         "https://linux-libre.fsfla.org/pub/linux-libre/releases/5.4.20-gnu/linux-libre-5.4.20-gnu.tar.xz",
--8<---------------cut here---------------end--------------->8---

First, it should be investigated why the deblob script
'5.12.14-gnu/deblob-5.12' appears 14 times.  In the same idea, the
source of 5.12.14 appears 28 times.  Well, I have tried to add
’delete-duplicates’ but without success.  To be continued… :-)

Second, I do not know if SWH ingests scripts as:

<https://linux-libre.fsfla.org/pub/linux-libre/releases/5.12.14-gnu/deblob-check>

and it is worth to carefully check with them. :-)

Last, the first patch tweaks the check to ease from the command-line the
build of the full website and not only 300 packages (otherwise it is
easy to miss corner cases ;-)).  Other said, turn
’GUIX_WEB_SITE_LOCAL=yes’ to ’GUIX_WEB_SITE_LOCAL=whatever-value’ (where
whatever-value can be ’no’ for instance) allows to build the full
website. It appears to me simpler than the previous check.  WDYT?


All the best,
simon


zimoun (2):
  website: Tweak 'GUIX_WEB_SITE_LOCAL'.
  website: Add 'computed-origin-method' packages to 'sources.json'.

 website/README                    |   3 +
 website/apps/packages/builder.scm | 134 +++++++++++++++++++-----------
 website/apps/packages/data.scm    |   3 +-
 3 files changed, 89 insertions(+), 51 deletions(-)


base-commit: d8efebc0794e8d6b2debc0e8a233a4b4b3b6f676
--
2.29.2

[bug#50515] [PATCH 1/2] website: Tweak 'GUIX_WEB_SITE_LOCAL'.

[zimoun]

* website/apps/packages/data.scm (%package-list): Compare to 'yes' instead of
any value.
* website/README: Document it.
---
 website/README                 | 3 +++
 website/apps/packages/data.scm | 3 ++-
 2 files changed, 5 insertions(+), 1 deletion(-)

diff --git a/website/README b/website/README
index ce2819f..19951d6 100644
--- a/website/README
+++ b/website/README
@@ -37,6 +37,9 @@ commands:
                           -- haunt build
 #+end_example
 
+Any other value than =GUIX_WEB_SITE_LOCAL=yes= will build the full website
+considering all the packages and not a small subset.
+
 ** Serve locally
 #+begin_example
   LANG=en_US.UTF-8 guix environment -CN -m manifest.scm \
diff --git a/website/apps/packages/data.scm b/website/apps/packages/data.scm
index d1bbc92..eb34d26 100644
--- a/website/apps/packages/data.scm
+++ b/website/apps/packages/data.scm
@@ -50,7 +50,8 @@
                    (string<? (package-name p1)
                              (package-name p2))))))
       (cond ((null? packages) '())
-            ((getenv "GUIX_WEB_SITE_LOCAL") (list-head packages 300))
+            ((string=? "yes" (getenv "GUIX_WEB_SITE_LOCAL"))
+             (list-head packages 300))
             (else packages)))))
 
 (define (all-packages)
-- 
2.29.2

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

[zimoun]

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 variable
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 | 134 +++++++++++++++++++-----------
 1 file changed, 84 insertions(+), 50 deletions(-)

diff --git a/website/apps/packages/builder.scm b/website/apps/packages/builder.scm
index fb53215..ecf958a 100644
--- a/website/apps/packages/builder.scm
+++ b/website/apps/packages/builder.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz>
-;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2020, 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; 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,67 @@
          (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)
+  (match uri
+    ((? promise? promise)               ;computed-origin-method
+     (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)))))
+    (_                                  ;represented 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))
-             `(("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)))
-          '())))
+             (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 +184,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 +217,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

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

[zimoun]

Hi,

Thanks for 50620.  However, because the package guix had not been
updated in the same time – see [2/2] of 50620 – it makes convoluted to
avoid:

--8<---------------cut here---------------start------------->8---
ERROR: In procedure %resolve-variable:
error: computed-origin-method: unbound variable
--8<---------------cut here---------------end--------------->8---

The package guix supports the previous location and as soon as it will
be updated the new location will be effective.  Because I am not
convinced that people (at least me) will track that; to make it work
with both locations means something along these lines:

--8<---------------cut here---------------start------------->8---
  (define computed-origin-method?
    (catch #t
      (lambda _
        (define computed-origin-method
          (@@ (guix packages) computed-origin-method))
        (lambda (method)
          (eq? method computed-origin-method)))
      (lambda _
        (lambda (method)
          (or (eq? method (@@ (gnu packages linux) computed-origin-method))
              (eq? method (@@ (gnu packages gnuzilla) computed-origin-method)))))))

  (if (computed-origin-method? method)
      ;; Packages in gnu/packages/gnuzilla.scm and gnu/packages/linux.scm
      ;; represent their 'uri' as 'promise'.
      (match uri
        ((? promise? promise)

[...]

      ;;Regular packages represent 'uri' as string.
      `((type . ,(cond ((or (eq? url-fetch method)
[...]
--8<---------------cut here---------------end--------------->8---

Update the package guix reduces to just:

--8<---------------cut here---------------start------------->8---
  (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)

[...]

      ;;Regular packages represent 'uri' as string.
      `((type . ,(cond ((or (eq? url-fetch method)
[...]
--8<---------------cut here---------------end--------------->8---

which had been the original aim of 50620.

Could you please update the package guix?  See [2/2] of 50620. :-)

Or do I miss something?

Cheers,
simon

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

[Ludovic Courtès]

Hi!

zimoun <zimon.toutoune@gmail.com> skribis:

> Could you please update the package guix?  See [2/2] of 50620. :-)

It’s not strictly necessary because the web site is built against the
latest Guix commit anyway.  You can try:

  guix build -f .guix.scm

HTH!

Ludo’.

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

[zimoun]

Hi,

v2 sent.  But not tested…

On Mon, 04 Oct 2021 at 09:53, Ludovic Courtès <ludo@gnu.org> wrote:
> zimoun <zimon.toutoune@gmail.com> skribis:
>
>> Could you please update the package guix?  See [2/2] of 50620. :-)
>
> It’s not strictly necessary because the web site is built against the
> latest Guix commit anyway.  You can try:
>
>   guix build -f .guix.scm

Running locally this command, I get this error.  That’s why I
think the recommendation using “guix environment -m manifest.scm” is
much easier.  Anyway!

--8<---------------cut here---------------start------------->8---
Running 'haunt build' for lingua de_DE...
Backtrace:
In haunt/ui.scm:
    125:6 19 (run-haunt-command _ . _)
In haunt/ui/build.scm:
     60:4 18 (haunt-build . _)
In haunt/site.scm:
   130:14 17 (build-site _)
In haunt/utils.scm:
    64:11 16 (flat-map _ . _)
In srfi/srfi-1.scm:
   586:29 15 (map1 _)
   586:29 14 (map1 _)
   586:29 13 (map1 _)
   586:29 12 (map1 _)
   586:17 11 (map1 (#<procedure 7fffed1d6380 at ice-9/boot-9.scm:…> …))
In unknown file:
          10 (_ #<procedure 7fffeabdf140 at ice-9/boot-9.scm:798:28…> …)
In ice-9/eval.scm:
    155:9  9 (_ _)
    155:9  8 (_ _)
   173:39  7 (_ #(#(#<directory (apps packages builder) 7ffff497…>) …))
   293:34  6 (_ #(#(#(#<directory (apps packages builder) 7ffff…>)) …))
    159:9  5 (_ #(#(#(#<directory (apps packages builder) 7ffff…>)) …))
    159:9  4 (_ _)
   196:43  3 (_ _)
In unknown file:
           2 (force #<promise #<procedure 7fffed0a0280 at ice-9/eval…>)
In ice-9/eval.scm:
   245:16  1 (_ #(#(#(#<directory (apps packages data) 7ffff497…>)) …))
In unknown file:
           0 (string=? "yes" #f)

ERROR: In procedure string=?:
In procedure string=: Wrong type argument in position 2 (expecting string): #f
building pages in '/tmp/gnu.org/software/guix'...
Backtrace:
--8<---------------cut here---------------end--------------->8---


Cheers,
simon

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

[Mark H Weaver]

Hi Simon,

> 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 variable
> from the module '(guix gexp)'.
> (origin->json): Add 'computed-origin-method' case.

Thanks for working on this.

> diff --git a/website/apps/packages/builder.scm b/website/apps/packages/builder.scm
> index fb53215..ecf958a 100644
> --- a/website/apps/packages/builder.scm
> +++ b/website/apps/packages/builder.scm
[...]
> @@ -106,53 +109,67 @@
>           (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)
> +  (match uri
> +    ((? promise? promise)               ;computed-origin-method
> +     (match (force promise)

Here, you're implicitly assuming that 'computed-origin-method' is the
only origin method that puts a promise in the 'uri' field.  That may be
true today, but it will not necessarily be true tomorrow, and therefore
it seems suboptimal to make that assumption in the code.

Instead, I would suggest checking for "computed origins" in the same way
that is done for the other cases: using 'eq?'.  It's not ideal, but it's
more future-proof than checking for a promise in the 'url' field, and
anyway it's the way things are currently being done.

However, there's a difficulty, and I suspect you're already aware of it
and that it's why you used the suboptimal approach above:

At present, 'computed-origin-method' is not exported by any Guix module,
nor is there even a unique definition of it.  Instead, there are two
copies of it, one in gnuzilla.scm and one in linux.scm.

The reason 'computed-origin-method' is not exported is because it never
went through the review process that such a radical new capability in
Guix should go through before becoming part of it's public API.

At the time that I added 'computed-origin-method', I was under time
pressure to push security updates for IceCat, and my previous method of
cherry picking dozens of upsteam patches and applying them to the most
recent IceCat release suddenly became impractical due to comprehensive
code reformatting done upstream.

I've always viewed 'computed-origin-method' as a temporary hack to work
around limitations in the 'snippet' mechanism.  Most importantly, last I
checked, it was not possible for a 'snippet' to produce a tarball with a
different base name than the original downloaded source.  I consider it
a *requirement* for the 'icecat' source tarball and it's unpacked
directory to be named "icecat-…" and not "firefox-…", and similarly for
'linux-libre'.

I'm sorry that I never found the energy to clean this up properly.

Anyway, regarding your proposed patch: for now, I would suggest the
following options:

(1) In a separate preceding commit, move 'computed-origin-method' to its
    own module, export it, use the exported one in gnuzilla.scm and
    linux.scm, and use 'eq?' to test for it in the code above.  There
    should probably also be a comment next to the definition of
    'computed-origin-method' pointing out that it's a temporary hack,
    hopefully to be superceded by snippets when they have gained the
    required functionality.

(2) Alternatively, for now, use 'eq?' against the two private copies
    (accessed using @@, see below), along with a "FIXME" comment.

___ (or (eq? method (@@ (gnu packages gnuzilla) computed-origin-method))
_______ (eq? method (@@ (gnu packages linux) computed-origin-method)))

What do you think?

I'm not on the guix-patches list, so please CC me on replies that you'd
like me to see.

       Thanks,
         Mark

-- 
Disinformation flourishes because many people care deeply about injustice
but very few check the facts.  Ask me about <https://stallmansupport.org>.

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

[zimoun]

Hi Mark,

Thanks for looking at the patch and for your inputs.


On Sat, 11 Sep 2021 at 20:54, Mark H Weaver <mhw@netris.org> wrote:

>> @@ -106,53 +109,67 @@
>>           (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)
>> +  (match uri
>> +    ((? promise? promise)               ;computed-origin-method
>> +     (match (force promise)
>
> Here, you're implicitly assuming that 'computed-origin-method' is the
> only origin method that puts a promise in the 'uri' field.  That may be
> true today, but it will not necessarily be true tomorrow, and therefore
> it seems suboptimal to make that assumption in the code.

Yes, I agree.  My initial draft contained something as your wrote below:

     (or (eq? method (@@ (gnu packages gnuzilla) computed-origin-method))
         (eq? method (@@ (gnu packages linux) computed-origin-method)))

but then, I thought it was a redundant test because then the promise
check is necessary to unwrap the values of embedded origins.  And
currently, all the 'computed-origin-method's use a promise.

> Instead, I would suggest checking for "computed origins" in the same way
> that is done for the other cases: using 'eq?'.  It's not ideal, but it's
> more future-proof than checking for a promise in the 'url' field, and
> anyway it's the way things are currently being done.

I cannot predict the future but the check about the method is as
suboptimal as mine. :-) If another package uses computed-origin-method,
then it should be added here.  However, from my understanding, there is
an higher probability that this hypothetical packages would use a
promise.

> However, there's a difficulty, and I suspect you're already aware of it
> and that it's why you used the suboptimal approach above:
>
> At present, 'computed-origin-method' is not exported by any Guix module,
> nor is there even a unique definition of it.  Instead, there are two
> copies of it, one in gnuzilla.scm and one in linux.scm.

Yes. :-)

> The reason 'computed-origin-method' is not exported is because it never
> went through the review process that such a radical new capability in
> Guix should go through before becoming part of it's public API.
>
> At the time that I added 'computed-origin-method', I was under time
> pressure to push security updates for IceCat, and my previous method of
> cherry picking dozens of upsteam patches and applying them to the most
> recent IceCat release suddenly became impractical due to comprehensive
> code reformatting done upstream.
>
> I've always viewed 'computed-origin-method' as a temporary hack to work
> around limitations in the 'snippet' mechanism.  Most importantly, last I
> checked, it was not possible for a 'snippet' to produce a tarball with a
> different base name than the original downloaded source.  I consider it
> a *requirement* for the 'icecat' source tarball and it's unpacked
> directory to be named "icecat-…" and not "firefox-…", and similarly for
> 'linux-libre'.

Thanks for explaining.

> Anyway, regarding your proposed patch: for now, I would suggest the
> following options:
>
> (1) In a separate preceding commit, move 'computed-origin-method' to its
>     own module, export it, use the exported one in gnuzilla.scm and
>     linux.scm, and use 'eq?' to test for it in the code above.  There
>     should probably also be a comment next to the definition of
>     'computed-origin-method' pointing out that it's a temporary hack,
>     hopefully to be superceded by snippets when they have gained the
>     required functionality.

I think it is the better approach.  Move the ’computed-origin-method’
procedure to (guix packages) and export it; add a comment about it.

However, I would not like that the sources.json situation stays blocked
by the computed-origin-method situation when sources.json is produced by
the website independently of Guix, somehow. :-)

Therefore, there is an option (3). Move the ’computed-origin-method’
procedure to (guix packages) and add a comment about it; use it for
icecat and linux with (@@ (guix packages) computed-origin-method).

WDYT about this (3)?  It simplifies this patch and let the time to
discuss the ’computed-origin-method’ case without exposing it to the
public API.

> (2) Alternatively, for now, use 'eq?' against the two private copies
>     (accessed using @@, see below), along with a "FIXME" comment.
>
> ___ (or (eq? method (@@ (gnu packages gnuzilla) computed-origin-method))
> _______ (eq? method (@@ (gnu packages linux) computed-origin-method)))

I commented above why I am not convinced that is better than directly
check the promise.  I do agree with the FIXME comment; the commit
message is not enough here.



Cheers,
simon

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

[Mark H Weaver]

Hi Simon,

zimoun <zimon.toutoune@gmail.com> writes:

> Therefore, there is an option (3). Move the ’computed-origin-method’
> procedure to (guix packages) and add a comment about it; use it for
> icecat and linux with (@@ (guix packages) computed-origin-method).
>
> WDYT about this (3)?  It simplifies this patch and let the time to
> discuss the ’computed-origin-method’ case without exposing it to the
> public API.

Sure, that sounds like a fine approach.

   Thank you!
      Mark

-- 
Disinformation flourishes because many people care deeply about injustice
but very few check the facts.  Ask me about <https://stallmansupport.org>.

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

[zimoun]

Hi Mark,

On Thu, 16 Sept 2021 at 02:08, Mark H Weaver <mhw@netris.org> wrote:
> zimoun <zimon.toutoune@gmail.com> writes:
>
> > Therefore, there is an option (3). Move the ’computed-origin-method’
> > procedure to (guix packages) and add a comment about it; use it for
> > icecat and linux with (@@ (guix packages) computed-origin-method).
> >
> > WDYT about this (3)?  It simplifies this patch and let the time to
> > discuss the ’computed-origin-method’ case without exposing it to the
> > public API.
>
> Sure, that sounds like a fine approach.

Done in patch#50620.

<http://issues.guix.gnu.org/50620>

Cheers,
simon

[bug#50515] [PATCH v2 1/2] website: Tweak 'GUIX_WEB_SITE_LOCAL'.

[zimoun]

* website/apps/packages/data.scm (%package-list): Compare to 'yes' instead of
any value.
* website/README: Document it.
---
 website/README                 | 8 ++++++++
 website/apps/packages/data.scm | 3 ++-
 2 files changed, 10 insertions(+), 1 deletion(-)

diff --git a/website/README b/website/README
index ce2819f..bc623c5 100644
--- a/website/README
+++ b/website/README
@@ -37,6 +37,14 @@ commands:
                           -- haunt build
 #+end_example
 
+Any other value than =GUIX_WEB_SITE_LOCAL=yes= will build the full website
+considering all the packages and not a small subset.  Note that the final
+website is built using the following command:
+
+#+begin_example
+  guix build -f .guix.scm
+#+end_example
+
 ** Serve locally
 #+begin_example
   LANG=en_US.UTF-8 guix environment -CN -m manifest.scm \
diff --git a/website/apps/packages/data.scm b/website/apps/packages/data.scm
index d1bbc92..eb34d26 100644
--- a/website/apps/packages/data.scm
+++ b/website/apps/packages/data.scm
@@ -50,7 +50,8 @@
                    (string<? (package-name p1)
                              (package-name p2))))))
       (cond ((null? packages) '())
-            ((getenv "GUIX_WEB_SITE_LOCAL") (list-head packages 300))
+            ((string=? "yes" (getenv "GUIX_WEB_SITE_LOCAL"))
+             (list-head packages 300))
             (else packages)))))
 
 (define (all-packages)
-- 
2.29.2

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

[zimoun]

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 <ludo@gnu.org>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz>
-;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2020, 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; 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

[bug#50515] (guix-artwork)[PATCH 0/2] List linux origins in 'sources.json'.

[Ludovic Courtès]

Hi!

zimoun <zimon.toutoune@gmail.com> skribis:

> 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.

Apologies for the looong delay!

> +;;; Required by 'origin->json' for 'computed-origin-method' corner cases
> +(define gexp-references (@@ (guix gexp) gexp-references))

Hmm not great.  The only public API that would allow us to approximate
it is ‘lower-gexp’, but it requires access to the daemon, so it’s not
suitable.

Let’s keep it this way!

>    (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)))))

Maybe we should just change ‘package->json’ to always return a list of
JSON records (alists)?  That way, we would write:

  (append-map package->json (all-packages))

which I find slightly clearer.

WDYT?

Otherwise LGTM, thanks!

Ludo’.

[bug#50515] (guix-artwork)[PATCH 0/2] List linux origins in 'sources.json'.

[zimoun]

Hi,

On Mon, 18 Oct 2021 at 14:23, Ludovic Courtès <ludo@gnu.org> wrote:

>>    (make-page "sources.json"
>> -             `(("sources" . ,(list->vector (map package->json (all-packages))))
>> +             `(("sources" . ,(list->vector (flatten (map package->json (all-packages)))))
>
> Maybe we should just change ‘package->json’ to always return a list of
> JSON records (alists)?  That way, we would write:
>
>   (append-map package->json (all-packages))
>
> which I find slightly clearer.

Done with v3.

Cheers,
simon

[bug#50515] [PATCH v3 1/2] website: Tweak 'GUIX_WEB_SITE_LOCAL'.

[zimoun]

* website/apps/packages/data.scm (%package-list): Compare to 'yes' instead of
any value.
* website/README: Document it.
---
 website/README                 | 8 ++++++++
 website/apps/packages/data.scm | 3 ++-
 2 files changed, 10 insertions(+), 1 deletion(-)

diff --git a/website/README b/website/README
index ce2819f..bc623c5 100644
--- a/website/README
+++ b/website/README
@@ -37,6 +37,14 @@ commands:
                           -- haunt build
 #+end_example
 
+Any other value than =GUIX_WEB_SITE_LOCAL=yes= will build the full website
+considering all the packages and not a small subset.  Note that the final
+website is built using the following command:
+
+#+begin_example
+  guix build -f .guix.scm
+#+end_example
+
 ** Serve locally
 #+begin_example
   LANG=en_US.UTF-8 guix environment -CN -m manifest.scm \
diff --git a/website/apps/packages/data.scm b/website/apps/packages/data.scm
index d1bbc92..eb34d26 100644
--- a/website/apps/packages/data.scm
+++ b/website/apps/packages/data.scm
@@ -50,7 +50,8 @@
                    (string<? (package-name p1)
                              (package-name p2))))))
       (cond ((null? packages) '())
-            ((getenv "GUIX_WEB_SITE_LOCAL") (list-head packages 300))
+            ((string=? "yes" (getenv "GUIX_WEB_SITE_LOCAL"))
+             (list-head packages 300))
             (else packages)))))
 
 (define (all-packages)

base-commit: 8b85fe7dd0bb000105f2bcd4955a7d2c6cd84298
-- 
2.29.2

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

[zimoun]

Using Guix 9875f9bca3976bf3576eab9be42164fde454597e, the packages considered
by 'computed-origin-method' 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.
---
 website/apps/packages/builder.scm | 127 +++++++++++++++++-------------
 1 file changed, 74 insertions(+), 53 deletions(-)

diff --git a/website/apps/packages/builder.scm b/website/apps/packages/builder.scm
index fb53215..b08ba2e 100644
--- a/website/apps/packages/builder.scm
+++ b/website/apps/packages/builder.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz>
-;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2020, 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; 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)
+            (append-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,8 @@
       ,@(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" . ,(list->vector
+                            (origin->json (package-source package)))))
             '())
       ("synopsis" . ,(package-synopsis package))
       ,@(if (package-home-page package)
@@ -195,11 +216,11 @@
   (define (package->json package)
     `(,@(if (origin? (package-source package))
             (origin->json (package-source package))
-            `(("type" . "no-origin")
-              ("name" . ,(package-name package))))))
+            `(((type . "no-origin")
+                ("name" . ,(package-name package)))))))
 
   (make-page "sources.json"
-             `(("sources" . ,(list->vector (map package->json (all-packages))))
+             `(("sources" . ,(list->vector (append-map package->json (all-packages))))
                ("version" . "1")
                ("revision" .
                 ,(match (current-profile)
-- 
2.29.2

bug#50515: (guix-artwork)[PATCH 0/2] List linux origins in 'sources.json'.

[Ludovic Courtès]

zimoun <zimon.toutoune@gmail.com> skribis:

> * website/apps/packages/data.scm (%package-list): Compare to 'yes' instead of
> any value.
> * website/README: Document it.

[...]

> Using Guix 9875f9bca3976bf3576eab9be42164fde454597e, the packages considered
> by 'computed-origin-method' 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.

Finally pushed, thanks!

Ludo’.