From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:470:142:3::10]:51121) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1j1CUb-0003Pq-Gn for guix-patches@gnu.org; Mon, 10 Feb 2020 12:05:06 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1j1CUZ-0004Wd-CC for guix-patches@gnu.org; Mon, 10 Feb 2020 12:05:04 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:49358) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1j1CUY-0004WM-TY for guix-patches@gnu.org; Mon, 10 Feb 2020 12:05:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1j1CUY-0004gB-Ng for guix-patches@gnu.org; Mon, 10 Feb 2020 12:05:02 -0500 Subject: [bug#39547] [PATCH] website: Provide JSON sources list used by Software Heritage. Resent-Message-ID: Received: from eggs.gnu.org ([2001:470:142:3::10]:50178) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1j1CTz-0002oJ-VK for guix-patches@gnu.org; Mon, 10 Feb 2020 12:04:29 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1j1CTx-0003q8-Me for guix-patches@gnu.org; Mon, 10 Feb 2020 12:04:27 -0500 Received: from mail-wr1-x443.google.com ([2a00:1450:4864:20::443]:46027) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1j1CTx-0003nL-Ad for guix-patches@gnu.org; Mon, 10 Feb 2020 12:04:25 -0500 Received: by mail-wr1-x443.google.com with SMTP id g3so7627938wrs.12 for ; Mon, 10 Feb 2020 09:04:24 -0800 (PST) From: zimoun Date: Mon, 10 Feb 2020 18:04:18 +0100 Message-Id: <20200210170418.32076-1-zimon.toutoune@gmail.com> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 39547@debbugs.gnu.org Cc: zimoun Format discussed here . * website/apps/packages/builder.scm (sources-json-builder): New procedure. --- website/apps/packages/builder.scm | 62 +++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) diff --git a/website/apps/packages/builder.scm b/website/apps/packages/builder.scm index 9dc44c9..5279096 100644 --- a/website/apps/packages/builder.scm +++ b/website/apps/packages/builder.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Ludovic Courtès ;;; Copyright © 2019 Ricardo Wurmus ;;; Copyright © 2019 Nicolò Balzarotti +;;; Copyright © 2020 Simon Tournier ;;; ;;; Initially written by sirgazil ;;; who waives all copyright interest on this file. @@ -37,6 +38,8 @@ #:use-module (haunt page) #:use-module (haunt utils) #:use-module (srfi srfi-1) + #:use-module ((web uri) #:select (string->uri uri->string uri-scheme)) + #:use-module ((guix build download) #:select (maybe-expand-mirrors)) #:use-module (guix packages) #:use-module (guix download) #:use-module (guix git-download) @@ -70,6 +73,7 @@ (flatten (list (index-builder) + (sources-json-builder) (packages-json-builder) (packages-builder) (package-list-builder)))) @@ -84,6 +88,64 @@ ;; Maximum number of packages shown on /packages. 30) +(define (sources-json-builder) + "Return a JSON page listing all the sources." + (define (origin->json origin) + (define method + (origin-method origin)) + + (define uri ;represented as string + (origin-uri origin)) + + (define (mirror->url uri) + (uri->string (car (maybe-expand-mirrors uri %mirrors)))) + + (define (resolve urls) + (let* ((url (car urls)) + (uri (string->uri url)) + (rest (cdr urls))) + (case (uri-scheme uri) + ((mirror) (mirror->url uri)) + ((http) url) + ((https) url) + (else + (if (null? rest) + url + (resolve rest)))))) + + `((type . ,(cond ((eq? url-fetch method) 'url) + ((eq? git-fetch method) 'git) + ((eq? svn-fetch method) 'svn) + (else #nil))) + ,@(cond ((eq? url-fetch method) + `(("url" . ,(match uri + ((? string? url) (mirror->url (string->uri url))) + ((urls ...) (resolve urls)))))) + ((eq? git-fetch method) + `(("git_url" . ,(git-reference-url uri)))) + ((eq? svn-fetch method) + `(("svn_url" . ,(svn-reference-url uri)))) + (else '())) + ,@(if (eq? method git-fetch) + `(("git_ref" . ,(git-reference-commit uri))) + '()) + ,@(if (eq? method svn-fetch) + `(("svn_revision" . ,(svn-reference-revision + uri))) + '()))) + + (define (package->json package) + `(,@(if (origin? (package-source package)) + (origin->json (package-source package)) + `(("type" . "no-origin") + ("name" . ,(package-name package)))))) + + (make-page "sources.json" + `(("sources" . ,(list->vector (map package->json (all-packages)))) + ("version" . "1")) + scm->json)) + + (define (packages-json-builder) "Return a JSON page listing all packages." (define (origin->json origin) -- 2.23.0