From: zimoun <zimon.toutoune@gmail.com>
To: 50515@debbugs.gnu.org
Cc: zimoun <zimon.toutoune@gmail.com>
Subject: [bug#50515] [PATCH v2 2/2] website: Add 'computed-origin-method' packages to 'sources.json'.
Date: Tue, 5 Oct 2021 16:09:37 +0200 [thread overview]
Message-ID: <20211005140937.19272-2-zimon.toutoune@gmail.com> (raw)
In-Reply-To: <20211005140937.19272-1-zimon.toutoune@gmail.com>
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
next prev parent reply other threads:[~2021-10-05 14:11 UTC|newest]
Thread overview: 17+ messages / expand[flat|nested] mbox.gz Atom feed top
2021-09-11 0:14 [bug#50515] (guix-artwork)[PATCH 0/2] List linux origins in 'sources.json' zimoun
2021-09-11 0:26 ` [bug#50515] [PATCH 1/2] website: Tweak 'GUIX_WEB_SITE_LOCAL' zimoun
2021-09-11 0:26 ` [bug#50515] [PATCH 2/2] website: Add 'computed-origin-method' packages to 'sources.json' zimoun
2021-10-01 14:16 ` zimoun
2021-10-04 7:53 ` Ludovic Courtès
2021-10-05 14:09 ` zimoun
2021-09-12 0:54 ` Mark H Weaver
2021-09-13 7:01 ` zimoun
2021-09-16 0:07 ` Mark H Weaver
2021-09-16 11:48 ` zimoun
2021-10-05 14:09 ` [bug#50515] [PATCH v2 1/2] website: Tweak 'GUIX_WEB_SITE_LOCAL' zimoun
2021-10-05 14:09 ` zimoun [this message]
2021-10-18 12:23 ` [bug#50515] (guix-artwork)[PATCH 0/2] List linux origins in 'sources.json' Ludovic Courtès
2021-10-21 9:42 ` zimoun
2021-10-21 9:41 ` [bug#50515] [PATCH v3 1/2] website: Tweak 'GUIX_WEB_SITE_LOCAL' zimoun
2021-10-21 9:41 ` [bug#50515] [PATCH v3 2/2] website: Add 'computed-origin-method' packages to 'sources.json' zimoun
2021-10-21 20:58 ` bug#50515: (guix-artwork)[PATCH 0/2] List linux origins in 'sources.json' Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20211005140937.19272-2-zimon.toutoune@gmail.com \
--to=zimon.toutoune@gmail.com \
--cc=50515@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).