diff mbox series

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

Message ID 20211005140937.19272-2-zimon.toutoune@gmail.com
State New
Headers show
Series [bug#50515,v2,1/2] website: Tweak 'GUIX_WEB_SITE_LOCAL'. | expand

Checks

Context Check Description
cbaines/applying patch fail View Laminar job
cbaines/issue success View issue
cbaines/applying patch fail View Laminar job
cbaines/issue success View issue
cbaines/applying patch fail View Laminar job
cbaines/issue success View issue
cbaines/applying patch fail View Laminar job
cbaines/issue success View issue
cbaines/applying patch fail View Laminar job
cbaines/issue success View issue
cbaines/applying patch fail View Laminar job
cbaines/issue success View issue

Commit Message

zimoun Oct. 5, 2021, 2:09 p.m. UTC
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(-)

Comments

Ludovic Courtès Oct. 18, 2021, 12:23 p.m. UTC | #1
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’.
zimoun Oct. 21, 2021, 9:42 a.m. UTC | #2
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
diff mbox series

Patch

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)