303 lines
12 KiB
Scheme
Executable File
303 lines
12 KiB
Scheme
Executable File
#!/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))
|