@@ -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,13 @@
(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; users can set the @code{repology-name} package property to
+make the updater use the correct name.
@end table
new file mode 100644
@@ -0,0 +1,226 @@
+;;; 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 diagnostics)
+ #:use-module (guix git-download)
+ #: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-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-"))))
+ (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-"))))
+ (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)
+ (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-url url old-version new-version)
+ "Replace OLD-VERSION in URL with NEW-VERSION."
+ (match (factorize-uri url old-version)
+ ((? string? uri) #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."
+ (let ((old-version (package-version package)))
+ ;; XXX: (guix upstream) only supports tarballs and Git repos for now.
+ (match (origin-uri (package-source package))
+ (($ <git-reference> url commit recursive?)
+ (and-let* ((updated-commit (if (string=? old-version commit)
+ version
+ (update-url commit old-version version))))
+ (list (git-reference
+ (url url)
+ (commit updated-commit)
+ (recursive? recursive?)))))
+ ((? string? url)
+ (list (update-url url old-version version)))
+ ((? list? urls)
+ (map (cut update-url <> old-version version) urls))
+ (_ #f))))
+
+(define (stable-version? repology-package)
+ (and (or (equal? "newest" (repology-package-status repology-package))
+ (equal? "unique" (repology-package-status repology-package)))
+ (repology-package-version repology-package)))
+
+;; XXX: '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 stable-version?
+ (vector->list packages)))
+ (latest-version (if (null? versions)
+ #f
+ (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,145 @@
+;;; 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 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)
+ (mock ((guix import json) json-fetch
+ (lambda (url)
+ (json-string->scm %test-json)))
+ (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"
+ (list (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")