GNU bug report logs - #39547
[PATCH] website: Provide JSON sources list used by Software Heritage.

Previous Next

Full log

Message #29 received at 39547 <at> debbugs.gnu.org (full text, mbox):

From: zimoun <zimon.toutoune <at> gmail.com>
To: 39547 <at> debbugs.gnu.org
Cc: zimoun <zimon.toutoune <at> gmail.com>
Subject: [PATCH v2 1/2] website: Refactor and resolve mirror:// of JSON
 package list.
Date: Tue, 18 Feb 2020 13:32:45 +0100

* website/apps/packages/builder.scm (origin->json): New procedure.
---
 website/apps/packages/builder.scm | 34 ++++++++++++++++++++++---------
 1 file changed, 24 insertions(+), 10 deletions(-)

diff --git a/website/apps/packages/builder.scm b/website/apps/packages/builder.scm
index 9dc44c9..d3a777e 100644
--- a/website/apps/packages/builder.scm
+++ b/website/apps/packages/builder.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado <at> elephly.net>
 ;;; Copyright © 2019 Nicolò Balzarotti <nicolo <at> nixo.xyz>
+;;; Copyright © 2020 Simon Tournier <zimon.toutoune <at> gmail.com>
 ;;;
 ;;; Initially written by sirgazil
 ;;; who waives all copyright interest on this file.
@@ -37,13 +38,16 @@
   #:use-module (haunt page)
   #:use-module (haunt utils)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
   #:use-module (guix svn-download)
   #:use-module (guix utils)                       ;location
+  #:use-module ((guix build download) #:select (maybe-expand-mirrors))
   #:use-module (json)
   #:use-module (ice-9 match)
+  #:use-module ((web uri) #:select (string->uri uri->string))
   #:export (builder))
 
 
@@ -84,33 +88,43 @@
   ;; Maximum number of packages shown on /packages.
   30)
 
-(define (packages-json-builder)
-  "Return a JSON page listing all packages."
-  (define (origin->json origin)
+(define (origin->json origin)
     (define method
       (origin-method origin))
 
+    (define uri                         ;represented as string
+      (origin-uri origin))
+
+    (define (resolve urls)
+      (map uri->string
+           (append-map (cut maybe-expand-mirrors <> %mirrors)
+                       (map string->uri urls))))
+
     `((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 (origin-uri origin)
-                             ((? string? url) (vector url))
-                             ((urls ...) (list->vector urls))))))
+               `(("url" . ,(list->vector
+                            (resolve
+                             (match uri
+                               ((? string? url) (list url))
+                               ((urls ...) urls)))))))
               ((eq? git-fetch method)
-               `(("git_url" . ,(git-reference-url (origin-uri origin)))))
+               `(("git_url" . ,(git-reference-url uri))))
               ((eq? svn-fetch method)
-               `(("svn_url" . ,(svn-reference-url (origin-uri origin)))))
+               `(("svn_url" . ,(svn-reference-url uri))))
               (else '()))
       ,@(if (eq? method git-fetch)
-            `(("git_ref" . ,(git-reference-commit (origin-uri origin))))
+            `(("git_ref" . ,(git-reference-commit uri)))
             '())
       ,@(if (eq? method svn-fetch)
             `(("svn_revision" . ,(svn-reference-revision
-                                  (origin-uri origin))))
+                                  uri)))
             '())))
 
+(define (packages-json-builder)
+  "Return a JSON page listing all packages."
   (define (package->json package)
     (define cpe-name
       (assoc-ref (package-properties package) 'cpe-name))
-- 
2.25.0

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.