01/02: hydra: Add 'build-package-metadata.scm' script.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository maintenance.

commit 318db3eedf70806cc4e058e37e3cc6c07594ff6e
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Jan 4 18:18:21 2023 +0100

    hydra: Add 'build-package-metadata.scm' script.
    
    This program produces the 'packages.json' and 'sources.json' files that
    are published at https://guix.gnu.org.
    
    So far those files were built as part of the web site's build process,
    via Haunt.  This script is adapted from the (apps packages builder)
    module of the web site.
    
    * hydra/build-package-metadata.scm: New file.
---
 hydra/build-package-metadata.scm | 227 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 227 insertions(+)

diff --git a/hydra/build-package-metadata.scm b/hydra/build-package-metadata.scm
new file mode 100755
index 0000000..9683db7
--- /dev/null
+++ b/hydra/build-package-metadata.scm
@@ -0,0 +1,227 @@
+#!/usr/bin/env -S guix repl --
+!#
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020, 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2023 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Build package metadata: 'packages.json', for package metadata, and
+;;; 'sources.json', for source code metadata.
+
+(use-modules (gnu packages)
+             (guix packages)
+             (guix channels)
+             (guix diagnostics)
+             (guix i18n)
+             (guix utils)
+             (guix gexp)
+             ((guix build download) #:select (maybe-expand-mirrors))
+             ((guix base64) #:select (base64-encode))
+             ((guix describe) #:select (current-profile))
+             ((guix config) #:select (%guix-version))
+             (guix download)
+             (guix git-download)
+             (guix svn-download)
+             (guix hg-download)
+             (json)
+             (web uri)
+             (ice-9 match)
+             (ice-9 vlist)
+             (srfi srfi-1)
+             (srfi srfi-26))
+
+(define (all-packages)             ;XXX: copied form 'etc/source-manifest.scm'
+  "Return the list of all the packages, public or private, omitting only
+superseded packages."
+  (fold-packages (lambda (package lst)
+                   (match (package-replacement package)
+                     (#f (cons package lst))
+                     (replacement
+                      (append (list replacement package) lst))))
+                 '()
+                 #:select? (negate package-superseded)))
+
+(define (all-origins)              ;XXX: copied form 'etc/source-manifest.scm'
+  "Return the list of origins referred to by all the packages."
+  (let loop ((packages (all-packages))
+             (origins  '())
+             (visited   vlist-null))
+    (match packages
+      ((head . tail)
+       (let ((new (remove (cut vhash-assq <> visited)
+                          (package-direct-sources head))))
+         (loop tail (append new origins)
+               (fold (cut vhash-consq <> #t <>)
+                     visited new))))
+      (()
+       origins))))
+
+;;; Required by 'origin->json' for 'computed-origin-method' corner cases
+(define gexp-references (@@ (guix gexp) gexp-references))
+
+(define (origin->json origin)
+  "Return a list of JSON representations (an alist) of ORIGIN."
+  (define method
+    (origin-method origin))
+
+  (define uri
+    (origin-uri origin))
+
+  (define (resolve urls)
+    (map uri->string
+         (append-map (cut maybe-expand-mirrors <> %mirrors)
+                     (map string->uri urls))))
+
+  (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)
+            (append-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 (package->json package)
+  (define cpe-name
+    (assoc-ref (package-properties package) 'cpe-name))
+  (define cpe-version
+    (assoc-ref (package-properties package) 'cpe-version))
+
+  `(("name"     . ,(package-name package))
+    ("version"  . ,(package-version package))
+    ,@(if cpe-name `(("cpe_name" . ,cpe-name)) '())
+    ,@(if cpe-version `(("cpe_version" . ,cpe-version)) '())
+    ,@(if (origin? (package-source package))
+          `(("source" . ,(list->vector
+                          (origin->json (package-source package)))))
+          '())
+    ("synopsis" . ,(package-synopsis package))
+    ,@(if (package-home-page package)
+          `(("homepage" . ,(package-home-page package)))
+          '())
+    ,@(match (package-location package)
+        ((? location? location)
+         `(("location"
+            . ,(string-append (location-file location) ":"
+                              (number->string
+                               (+ 1 (location-line location)))))))
+        (#f
+         '()))))
+
+
+(define (sources-json)
+  "Return JSON (an alist) listing all the sources."
+  ;; The Software Heritage format is described here:
+  ;; 
https://forge.softwareheritage.org/source/swh-loader-core/browse/master/swh/loader/package/nixguix/tests/data/https_nix-community.github.io/nixpkgs-swh_sources.json
+  ;; And the loader is implemented here:
+  ;; 
https://forge.softwareheritage.org/source/swh-loader-core/browse/master/swh/loader/package/nixguix/
+  `(("sources" . ,(list->vector (append-map origin->json (all-origins))))
+    ("version" . "1")
+    ("revision" .
+     ,(match (current-profile)
+        (#f %guix-version)                        ;for lack of a better ID
+        (profile
+         (let ((channel (find guix-channel? (profile-channels profile))))
+           (channel-commit channel)))))))
+
+(define (packages-json)
+  "Return JSON (an alist) listing all the packages."
+  (list->vector (map package->json (all-packages))))
+
+(define (write-json json file)
+  "Serialize JSON to FILE."
+  (with-atomic-file-output file
+    (lambda (port)
+      (scm->json json port))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define-public (main . args)
+  (match args
+    ((_ directory)
+     (info (G_ "package metadata will be written to '~a'~%") directory)
+     (for-each (lambda (thunk file)
+                 (write-json (thunk)
+                             (string-append directory "/" file)))
+               (list packages-json sources-json)
+               '("packages.json" "sources.json")))
+    ((command . _)
+     (leave (G_ "Usage: ~a DIRECTORY
+
+Write 'packages.json' and 'sources.json' files to DIRECTORY.\n")
+            (basename command)))))
+
+(apply main (command-line))