@@ -16,6 +16,7 @@
# Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
# Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
# Copyright © 2021 Andrew Tropin <andrew@trop.in>
+# Copyright © 2022 Xinglu Chen <public@yoctocell.xyz>
#
# This file is part of GNU Guix.
#
@@ -271,6 +272,7 @@ MODULES = \
guix/import/opam.scm \
guix/import/print.scm \
guix/import/pypi.scm \
+ guix/import/repology.scm \
guix/import/stackage.scm \
guix/import/texlive.scm \
guix/import/utils.scm \
@@ -488,6 +490,7 @@ SCM_TESTS = \
tests/home-import.scm \
tests/import-git.scm \
tests/import-github.scm \
+ tests/import-repology.scm \
tests/import-utils.scm \
tests/inferior.scm \
tests/lint.scm \
@@ -12932,6 +12932,14 @@
(release-tag-version-delimiter . ":"))))
@end lisp
+@item repology
+an updater that scans @uref{https://repology.org, Repology}, a website
+that tracks packages on various package repositories, for updates.
+
+The name of a package in Guix is not always that same as the name on
+Repology. In most cases, the updater will be able to guess the name
+correctly. If it doesn’t, users can set the @code{repology-name}
+package property.
@end table
new file mode 100644
@@ -0,0 +1,249 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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/>.
+
+(define-module (guix import repology)
+ #:use-module (guix diagnostics)
+ #:use-module (guix git-download)
+ #:use-module (guix http-client)
+ #:use-module (guix i18n)
+ #:use-module (guix import json)
+ #:use-module (guix import utils)
+ #:use-module (guix memoization)
+ #:use-module (guix packages)
+ #:use-module (guix upstream)
+ #:use-module (guix utils)
+ #:use-module (ice-9 match)
+ #:use-module (json)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-43)
+ #:export (%repology-url
+ repology-fetch-info
+ repology-latest-release
+ %repology-updater))
+
+;;; Commentary:
+;;;
+;;; This module provides an updater which scans Repology, a site that monitors
+;;; several package repolsitories, for updates. This means that if any other
+;;; package repository has a version of a package that is newer than the
+;;; version in Guix, the package should be able to be updated. The updater
+;;; should in theory work for all packages in Guix, but the names of some
+;;; packages on Repology don't match the name in Guix. The 'repology-name'
+;;; package property can be used to fix this.
+;;;
+;;; Guix already has many different updaters for language-specific packages,
+;;; and these typically provide more accurate data, e.g., input changes,
+;;; signature URLs. The Repology updater should really be treated as a last
+;;; resort for those packages that don't have any other updater to rely on.
+;;;
+;;; See <https://repology.org/api/v1> for the API.
+;;;
+;;; Code:
+
+(define %repology-url
+ "https://repology.org/api/v1/project")
+
+(define* (package-name->repology-name name #:key (attempt 1))
+ "Convert NAME, the name of a Guix package, to the name of the package on
+Repology. It doesn't always guess the correct name on the first attempt, so
+on the second attempt it will try to guess another name."
+ (match attempt
+ (1 (cond
+ ((string-prefix? "ghc-" name)
+ (string-append "haskell:"
+ (string-drop name (string-length "ghc-"))))
+ ((string-prefix? "ocaml-" name)
+ (string-append "ocaml:"
+ (string-drop name (string-length "ocaml-"))))
+ ((string-prefix? "perl-" name)
+ (string-append "perl:"
+ (string-drop name (string-length "perl-"))))
+ ((string-prefix? "emacs-" name)
+ (string-append "emacs:"
+ (string-drop name (string-length "emacs-"))))
+ ((string-prefix? "go-" name)
+ (string-append "go:"
+ (string-drop name (string-length "go-"))))
+ ((string-prefix? "rust-" name)
+ (string-append "rust:"
+ (string-drop name (string-length "rust-"))))
+ ((string-prefix? "lua-" name)
+ (string-append "lua:"
+ (string-drop name (string-length "lua-"))))
+ ((string-prefix? "node-" name)
+ (string-append "node:"
+ (string-drop name (string-length "node-"))))
+ ((string-prefix? "python-" name)
+ (string-append "python:"
+ (string-drop name (string-length "python-"))))
+ ((string-prefix? "java-" name)
+ (string-append "java:"
+ (string-drop name (string-length "java-"))))
+ ((string-prefix? "r-" name)
+ (string-append "r:"
+ (string-drop name (string-length "r-"))))
+ ((string-prefix? "ruby-" name)
+ (string-append "ruby:"
+ (string-drop name (string-length "ruby-"))))
+ ((string-prefix? "xf86-" name)
+ (string-append "xdrv:"
+ (string-drop name (string-length "xf86-"))))
+ ((string-prefix? "font-" name)
+ (string-append "fonts:"
+ (string-drop name (string-length "font-"))))
+ ((string-prefix? "trytond-" name)
+ (string-append "tryton:"
+ (string-drop name (string-length "trytond-"))))
+ ((string-prefix? "python-trytond-" name)
+ (string-append "tryton:"
+ (string-drop name (string-length "python-trytond-"))))
+ ((string-suffix? "-minimal" name)
+ (string-drop-right name (string-length "-minimal")))
+ (else name)))
+ (2 (cond
+ ((string-prefix? "xf86-video" name)
+ (string-append "xdrv:"
+ (string-drop name (string-length "xf86-video-"))))
+ ((string-prefix? "xf86-input" name)
+ (string-append "xdrv:"
+ (string-drop name (string-length "xf86-input-"))))
+ ((string-prefix? "minetest-" name)
+ (string-append "minetest-mod-"
+ (string-drop name (string-length "minetest-"))))
+ ((string-prefix? "lib" name)
+ (string-drop name (string-length "lib")))
+ ((string-prefix? "vim-" name)
+ (string-append "vim:"
+ (string-drop name (string-length "vim-"))))
+ (else name)))))
+
+
+;;; JSON mappings.
+
+(define-json-mapping <repology-package> make-repology-package
+ repology-package?
+ json->repology-package
+ (repository repology-package-repository "repo")
+ (src-name repology-package-src-name "srcname")
+ (binary-name repology-package-binary-name "binname")
+ (visible-name repology-package-visible-name "visiblename")
+ (version repology-package-version)
+ (original-version repology-package-original-version "origversion")
+ (status repology-package-status)
+ (summary repology-package-summary)
+ (categories repology-package-categories)
+ (licenses repology-package-licenses)
+ (maintainers repology-package-maintainers))
+
+
+;;; Updater.
+
+(define repology-fetch-info
+ (memoize
+ (lambda (package)
+ "Fetch information about PACKAGE using the Repology API."
+ (define (name->info name)
+ (let ((url (string-append %repology-url "/" name)))
+ (and=> (json-fetch url #:http-fetch http-fetch/cached)
+ (lambda (url)
+ (vector-map (lambda (a b)
+ (json->repology-package b))
+ url)))))
+
+ (let* ((name (or (assoc-ref (package-properties package)
+ 'repology-name)
+ (package-name->repology-name (package-name package))))
+ (info (name->info name)))
+ (if (and info (not (vector-empty? info)))
+ info
+ (let ((info (name->info (package-name->repology-name
+ (package-name package)
+ #:attempt 2))))
+ (if (and info (not (vector-empty? info)))
+ info
+ (begin
+ (warning (G_ "package not found on Repology: ~a\n")
+ (package-name package))
+ #f))))))))
+
+(define (update-version string old-version new-version)
+ "Replace OLD-VERSION in STRING with NEW-VERSION. This assumes that STRING
+contains OLD-VERSION verbatim; if it doesn't, #f is returned."
+ (match (factorize-uri string old-version)
+ ((? string?) #f)
+ ((factorized ...)
+ (apply string-append
+ (map (lambda (component)
+ (match component
+ ('version new-version)
+ ((? string?) component)))
+ factorized)))))
+
+(define (package-source-urls package version)
+ "Return a list of URLs for PACKAGE at VERSION. If no URL was successfully constructed, return #f."
+ (and-let* ((old-version (package-version package))
+ (source (package-source package)))
+ ;; XXX: (guix upstream) only supports tarballs and Git repos for now.
+ (match (origin-uri source)
+ ((? git-reference? reference)
+ (and-let* ((old-commit (git-reference-commit reference))
+ (new-commit (if (string=? old-version old-commit)
+ version
+ (update-version old-commit
+ old-version
+ version))))
+ (git-reference
+ (inherit reference)
+ (commit new-commit))))
+ ((? string? url)
+ (list (update-version url old-version version)))
+ ((? list? urls)
+ (map (cut update-version <> old-version version) urls))
+ (_ #f))))
+
+(define (latest-version? repology-package)
+ "Return the latest released version of REPOLOGY-PACKAGE. If none are found,
+return #f."
+ (and (or (equal? "newest" (repology-package-status repology-package))
+ (equal? "unique" (repology-package-status repology-package)))
+ (repology-package-version repology-package)))
+
+;; XXX: We use 'pkg' because 'package' will clash with the 'package' field of
+;; 'upstream-source'.
+(define (repology-latest-release pkg)
+ "Return the latest release of the PKG on Repology named NAME."
+ (and-let* ((packages (repology-fetch-info pkg))
+ (versions (filter-map latest-version?
+ (vector->list packages)))
+ (latest-version (and (pair? versions) (car versions))))
+ ;; TODO: set 'signature-urls'.
+ (upstream-source
+ (package (package-name pkg))
+ (version latest-version)
+ (urls (package-source-urls pkg latest-version)))))
+
+(define %repology-updater
+ (upstream-updater
+ (name 'repology)
+ (description "Updater for packages on Repology")
+ (pred (const #t))
+ (latest repology-latest-release)))
+
+;;; repology.scm ends here
new file mode 100644
@@ -0,0 +1,150 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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/>.
+
+(define-module (test-import-repology)
+ #:use-module (guix download)
+ #:use-module (guix git-download)
+ #:use-module (guix import repology)
+ #:use-module (guix memoization)
+ #:use-module (guix packages)
+ #:use-module (guix tests)
+ #:use-module (guix upstream)
+ #:use-module (json)
+ #:use-module (srfi srfi-64))
+
+(test-begin "repology")
+
+(define package-using-git-repository
+ (dummy-package
+ "foo"
+ (version "1.0")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://git.example.org/foo")
+ (commit "1.0")))
+ (sha256 #f)))))
+
+(define package-using-tarball
+ (dummy-package
+ "foo"
+ (version "1.0")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (string-append "https://example.org/foo-" version ".tar.gz"))
+ (sha256 #f)))))
+
+(define package-using-tarball-multiple-urls
+ (dummy-package
+ "foo"
+ (version "1.0")
+ (source
+ (origin
+ (method git-fetch)
+ (uri (list (string-append "https://example.org/foo-"
+ version ".tar.gz")
+ (string-append "https://mirror.example.org/foo-"
+ version ".tar.gz")))
+ (sha256 #f)))))
+
+(define %test-json
+"[
+ {
+ \"repo\": \"aur\",
+ \"srcname\": \"foo\",
+ \"binname\": \"foo\",
+ \"visiblename\": \"foo\",
+ \"version\": \"1.0.r25.gb86405a\",
+ \"maintainers\": [
+ \"bob@aur\"
+ ],
+ \"licenses\": [
+ \"LGPL3+\"
+ ],
+ \"summary\": \"foo bar\"
+ \"status\": \"rolling\",
+ \"origversion\": \"1.0.r25.gb86405a-1\"
+ },
+ {
+ \"repo\": \"gnuguix\",
+ \"srcname\": \"foo\",
+ \"binname\": \"foo\",
+ \"visiblename\": \"foo\",
+ \"version\": \"1.0\",
+ \"summary\": \"foo bar\",
+ \"status\": \"outdated\",
+ \"origversion\": null
+ },
+ {
+ \"repo\": \"nix_unstable\",
+ \"name\": \"foo\",
+ \"visiblename\": \"foo\",
+ \"version\": \"2.0\",
+ \"maintainers\": [
+ \"bob@example.org\"
+ ],
+ \"licenses\": [
+ \"LGPL-3.0-or-later\"
+ ],
+ \"summary\": \"foo bar\",
+ \"status\": \"newest\",
+ \"origversion\": null
+ }
+]")
+
+(define (latest-release package)
+ (invalidate-memoization! repology-fetch-info)
+ (mock ((guix import json) json-fetch
+ (lambda* (url #:key http-fetch)
+ (if (string=? url
+ (string-append %repology-url "/foo"))
+ (json-string->scm %test-json)
+ (error "the URL is not correct"))))
+ (repology-latest-release package)))
+
+(test-equal "package using Git repo: version"
+ "2.0"
+ (upstream-source-version
+ (latest-release package-using-git-repository)))
+
+(test-equal "package using Git repo: git-reference"
+ (git-reference
+ (url "https://git.example.org/foo")
+ (commit "2.0"))
+ (upstream-source-urls
+ (latest-release package-using-git-repository)))
+
+(test-equal "package using tarball: version"
+ "2.0"
+ (upstream-source-version
+ (latest-release package-using-tarball)))
+
+(test-equal "package using tarball: URL"
+ (list "https://example.org/foo-2.0.tar.gz")
+ (upstream-source-urls
+ (latest-release package-using-tarball)))
+
+(test-equal "package using tarball: multiple URLs"
+ (list "https://example.org/foo-2.0.tar.gz"
+ "https://mirror.example.org/foo-2.0.tar.gz")
+ (upstream-source-urls
+ (latest-release package-using-tarball-multiple-urls)))
+
+(test-end "repology")