unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
* [bug#39547] [PATCH] website: Provide JSON sources list used by Software Heritage.
@ 2020-02-10 17:04 zimoun
  2020-02-14  8:40 ` Ludovic Courtès
                   ` (3 more replies)
  0 siblings, 4 replies; 18+ messages in thread
From: zimoun @ 2020-02-10 17:04 UTC (permalink / raw)
  To: 39547; +Cc: zimoun

Format discussed here <https://forge.softwareheritage.org/D2025#51269>.

* 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 <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>
 ;;;
 ;;; 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

^ permalink raw reply related	[flat|nested] 18+ messages in thread

end of thread, other threads:[~2020-03-09  9:54 UTC | newest]

Thread overview: 18+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-02-10 17:04 [bug#39547] [PATCH] website: Provide JSON sources list used by Software Heritage zimoun
2020-02-14  8:40 ` Ludovic Courtès
2020-02-14  9:04   ` zimoun
2020-02-14 10:20     ` Ludovic Courtès
2020-02-17 17:59       ` zimoun
2020-02-18  8:24         ` Ludovic Courtès
2020-02-18  8:38           ` zimoun
2020-02-18  8:43             ` Ludovic Courtès
2020-02-18 12:32 ` [bug#39547] [PATCH v2 1/2] website: Refactor and resolve mirror:// of JSON package list zimoun
2020-02-18 12:32   ` [bug#39547] [PATCH v2 2/2] website: Provide JSON sources list used by Software Heritage zimoun
2020-03-02 17:24 ` [bug#39547] [PATCH v3] sources.json: array instead of list zimoun
2020-03-06 11:01   ` Ludovic Courtès
2020-03-07 22:17     ` zimoun
2020-03-09  9:53       ` bug#39547: " Ludovic Courtès
2020-03-03 18:00 ` [bug#39547] Addition of %content-addressed-mirrors to sources.json (SWH)? zimoun
2020-03-05 16:19   ` Ludovic Courtès
2020-03-06  9:26     ` zimoun
2020-03-06 10:57       ` Ludovic Courtès

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