maintenance/hydra/build-package-metadata.scm

#!/usr/bin/env -S guix repl --
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2021, 2023 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 base32) #:select (bytevector->nix-base32-string))
             ((guix base64) #:select (base64-encode))
             ((guix describe) #:select (current-profile))
             ((guix config) #:select (%guix-version))
             ((guix modules) #:select (file-name->module-name))
             (guix download)
             (guix git-download)
             (guix svn-download)
             (guix hg-download)
             (json)
             (zlib)
             (web uri)
             ((ice-9 control) #:select (let/ec))
             (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 %content-addressed-mirrors
  ;; List of content-addressed mirrors.
  ;; XXX: somewhat duplicated from (guix download)
  (let ((guix-publish
         (lambda (host)
           (lambda (file hash)
             ;; Files served by 'guix publish'.
             (string-append "https://" host "/file/"
                            file "/" (symbol->string
                                      (content-hash-algorithm hash))
                            "/" (bytevector->nix-base32-string
                                 (content-hash-value hash)))))))

    (list (guix-publish "bordeaux.guix.gnu.org")
          (guix-publish "ci.guix.gnu.org")
          (lambda (file hash)
            (string-append "https://tarballs.nixos.org/"
                           (symbol->string (content-hash-algorithm hash))
                           "/" (bytevector->nix-base32-string
                                (content-hash-value hash)))))))

(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 hash)
    (append (map uri->string
                 (append-map (cut maybe-expand-mirrors <> %mirrors)
                             (map string->uri urls)))
            (if hash
                (let ((file (origin-actual-file-name origin))
                      (hash (origin-hash origin)))
                  (map (lambda (make-url)
                         (make-url file hash))
                       %content-addressed-mirrors))
                '())))

  (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))
                                 (origin-hash origin))))))
                 ((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)
                   (eq? git-fetch method)
                   (eq? svn-fetch method)
                   (eq? svn-multi-fetch method)
                   (eq? hg-fetch 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)))
                   ("outputHashAlgo" . ,algorithm-string)
                   ("outputHashMode" . ,(if (or (eq? url-fetch method)
                                                (eq? url-fetch/tarbomb method)
                                                (eq? url-fetch/zipbomb method))
                                            "flat"
                                            "recursive"))))
               '())
         ,@(if (eq? method git-fetch)
               `(("git_ref" . ,(git-reference-commit uri))
                 ,@(if (git-reference-recursive? uri)
                       '(("submodule" . #true))
                       '()))
               '())
         ,@(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-variable-name package)
  "Return the name of the variable whose value is PACKAGE in the module that
defines it, or #f if this could not be determined."
  (match (package-location package)
    (#f #f)
    ((= location-file file)
     (let* ((name (file-name->module-name file))
            (module (false-if-exception (resolve-interface name))))
       (let/ec return
         (module-for-each (lambda (symbol variable)
                            (when (eq? package (variable-ref variable))
                              (return symbol)))
                          module)
         #f)))))

(define (package->json package)
  (define cpe-name
    (assoc-ref (package-properties package) 'cpe-name))
  (define cpe-version
    (assoc-ref (package-properties package) 'cpe-version))
  (define variable
    (package-variable-name package))

  `(("name"     . ,(package-name package))
    ("version"  . ,(package-version package))
    ,@(if variable `(("variable_name" . ,variable)) '())
    ,@(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 and compress JSON to FILE."
  (let ((pivot (string-append file ".tmp")))
    ;; Note: 'with-atomic-file-output' doesn't work well with
    ;; 'call-with-gzip-output-port' since the latter closes its underlying
    ;; port.
    (call-with-output-file pivot
      (lambda (port)
        (chmod port #o644)
        (call-with-gzip-output-port port
          (lambda (port)
            (set-port-encoding! port "UTF-8")
            (scm->json json port))
          #:buffer-size (expt 2 16)
          #:level 9)))
    (rename-file pivot file)))


;;;
;;; 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.gz" "sources.json.gz")))
    ((command . _)
     (leave (G_ "Usage: ~a DIRECTORY

Write 'packages.json' and 'sources.json' files to DIRECTORY.\n")
            (basename command)))))

(apply main (command-line))