From 358ad74f41a59b177c9961abf49753a7ce3f41a0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 18 Sep 2021 18:24:05 +0200 Subject: tests: Allow opam test to run without networking. Fixes a regression introduced in fc29c80b9635ff490bcc768c774442043cb1e231, where, since 'get-opam-repository' was no longer mocked, the test would try to access the actual OPAM repository through a call to 'http-fetch/cached'; this would lead to a test failure when networking is unavailable. * tests/opam.scm ("opam->guix-package"): Mock 'get-opam-repository' again. --- tests/opam.scm | 90 ++++++++++++++++++++++++++++++---------------------------- 1 file changed, 46 insertions(+), 44 deletions(-) (limited to 'tests') diff --git a/tests/opam.scm b/tests/opam.scm index 1536b74339..31b4ea41ff 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -71,50 +71,52 @@ url { (test-begin "opam") (test-assert "opam->guix-package" - (mock ((guix import utils) url-fetch - (lambda (url file-name) - (match url - ("https://example.org/foo-1.0.0.tar.gz" - (begin - (mkdir-p "foo-1.0.0") - (system* "tar" "czvf" file-name "foo-1.0.0/") - (delete-file-recursively "foo-1.0.0") - (set! test-source-hash - (call-with-input-file file-name port-sha256)))) - (_ (error "Unexpected URL: " url))))) - (let ((my-package (string-append test-repo - "/packages/foo/foo.1.0.0"))) - (mkdir-p my-package) - (with-output-to-file (string-append my-package "/opam") - (lambda _ - (format #t "~a" test-opam-file)))) - (match (opam->guix-package "foo" #:repo (list test-repo)) - (('package - ('name "ocaml-foo") - ('version "1.0.0") - ('source ('origin - ('method 'url-fetch) - ('uri "https://example.org/foo-1.0.0.tar.gz") - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'ocaml-build-system) - ('propagated-inputs - ('quasiquote - (("ocaml-zarith" ('unquote 'ocaml-zarith))))) - ('native-inputs - ('quasiquote - (("ocaml-alcotest" ('unquote 'ocaml-alcotest)) - ("ocamlbuild" ('unquote 'ocamlbuild))))) - ('home-page "https://example.org/") - ('synopsis "Some example package") - ('description "This package is just an example.") - ('license 'license:bsd-3)) - (string=? (bytevector->nix-base32-string - test-source-hash) - hash)) - (x - (pk 'fail x #f))))) + (mock ((guix import opam) get-opam-repository + (const test-repo)) + (mock ((guix import utils) url-fetch + (lambda (url file-name) + (match url + ("https://example.org/foo-1.0.0.tar.gz" + (begin + (mkdir-p "foo-1.0.0") + (system* "tar" "czvf" file-name "foo-1.0.0/") + (delete-file-recursively "foo-1.0.0") + (set! test-source-hash + (call-with-input-file file-name port-sha256)))) + (_ (error "Unexpected URL: " url))))) + (let ((my-package (string-append test-repo + "/packages/foo/foo.1.0.0"))) + (mkdir-p my-package) + (with-output-to-file (string-append my-package "/opam") + (lambda _ + (format #t "~a" test-opam-file)))) + (match (opam->guix-package "foo" #:repo (list test-repo)) + (('package + ('name "ocaml-foo") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri "https://example.org/foo-1.0.0.tar.gz") + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'ocaml-build-system) + ('propagated-inputs + ('quasiquote + (("ocaml-zarith" ('unquote 'ocaml-zarith))))) + ('native-inputs + ('quasiquote + (("ocaml-alcotest" ('unquote 'ocaml-alcotest)) + ("ocamlbuild" ('unquote 'ocamlbuild))))) + ('home-page "https://example.org/") + ('synopsis "Some example package") + ('description "This package is just an example.") + ('license 'license:bsd-3)) + (string=? (bytevector->nix-base32-string + test-source-hash) + hash)) + (x + (pk 'fail x #f)))))) ;; Test the opam file parser ;; We fold over some test cases. Each case is a pair of the string to parse and the -- cgit 1.4.1 From 59ee10754eddddb99e4a80b9e18aa12ed1b3d77a Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Fri, 17 Sep 2021 10:04:49 +0200 Subject: import: Add 'generic-git' updater. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/git.scm (ls-remote-refs): New procedure. * tests/git.scm ("remote-refs" "remote-refs: only tags"): New tests. * guix/import/git.scm: New file. * doc/guix.texi (Invoking guix refresh): Document it. * tests/import-git.scm: New test file. * Makefile.am (MODULES, SCM_TESTS): Register the new files. Co-authored-by: Sarah Morgensen Signed-off-by: Ludovic Courtès --- Makefile.am | 2 + doc/guix.texi | 34 +++++++ guix/git.scm | 41 +++++++++ guix/import/git.scm | 225 ++++++++++++++++++++++++++++++++++++++++++++++ tests/git.scm | 28 ++++++ tests/import-git.scm | 245 +++++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 575 insertions(+) create mode 100644 guix/import/git.scm create mode 100644 tests/import-git.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 299bc0f7fb..f3bdc7448e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -254,6 +254,7 @@ MODULES = \ guix/import/egg.scm \ guix/import/elpa.scm \ guix/import/gem.scm \ + guix/import/git.scm \ guix/import/github.scm \ guix/import/gnome.scm \ guix/import/gnu.scm \ @@ -473,6 +474,7 @@ SCM_TESTS = \ tests/graph.scm \ tests/gremlin.scm \ tests/hackage.scm \ + tests/import-git.scm \ tests/import-utils.scm \ tests/inferior.scm \ tests/lint.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 2fc9687910..6436e83a7c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11928,6 +11928,40 @@ the updater for @uref{https://launchpad.net, Launchpad} packages. @item generic-html a generic updater that crawls the HTML page where the source tarball of the package is hosted, when applicable. + +@item generic-git +a generic updater for packages hosted on Git repositories. It tries to +be smart about parsing Git tag names, but if it is not able to parse the +tag name and compare tags correctly, users can define the following +properties for a package. + +@itemize +@item @code{release-tag-prefix}: a regular expression for matching a prefix of +the tag name. + +@item @code{release-tag-suffix}: a regular expression for matching a suffix of +the tag name. + +@item @code{release-tag-version-delimiter}: a string used as the delimiter in +the tag name for separating the numbers of the version. + +@item @code{accept-pre-releases}: by default, the updater will ignore +pre-releases; to make it also look for pre-releases, set the this +property to @code{#t}. + +@end itemize + +@lisp +(package + (name "foo") + ;; ... + (properties + '((release-tag-prefix . "^release0-") + (release-tag-suffix . "[a-z]?$") + (release-tag-version-delimiter . ":")))) +@end lisp + + @end table For instance, the following command only checks for updates of Emacs diff --git a/guix/git.scm b/guix/git.scm index acc48fd12f..bbff4fc890 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -57,6 +57,8 @@ commit-difference commit-relation + remote-refs + git-checkout git-checkout? git-checkout-url @@ -571,6 +573,45 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or (if (set-contains? oldest new) 'descendant 'unrelated)))))) + +;; +;;; Remote operations. +;;; + +(define* (remote-refs url #:key tags?) + "Return the list of references advertised at Git repository URL. If TAGS? +is true, limit to only refs/tags." + (define (ref? ref) + ;; Like `git ls-remote --refs', only show actual references. + (and (string-prefix? "refs/" ref) + (not (string-suffix? "^{}" ref)))) + + (define (tag? ref) + (string-prefix? "refs/tags/" ref)) + + (define (include? ref) + (and (ref? ref) + (or (not tags?) (tag? ref)))) + + (define (remote-head->ref remote) + (let ((name (remote-head-name remote))) + (and (include? name) + name))) + + (with-libgit2 + (call-with-temporary-directory + (lambda (cache-directory) + (let* ((repository (repository-init cache-directory)) + ;; Create an in-memory remote so we don't touch disk. + (remote (remote-create-anonymous repository url))) + (remote-connect remote) + + (let* ((remote-heads (remote-ls remote)) + (refs (filter-map remote-head->ref remote-heads))) + ;; Wait until we're finished with the repository before closing it. + (remote-disconnect remote) + (repository-close! repository) + refs)))))) ;;; diff --git a/guix/import/git.scm b/guix/import/git.scm new file mode 100644 index 0000000000..1eb219f3fe --- /dev/null +++ b/guix/import/git.scm @@ -0,0 +1,225 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen +;;; Copyright © 2021 Sarah Morgensen +;;; +;;; 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 . + +(define-module (guix import git) + #:use-module (guix build utils) + #:use-module (guix diagnostics) + #:use-module (guix git) + #:use-module (guix git-download) + #:use-module (guix i18n) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export (%generic-git-updater + + ;; For tests. + latest-git-tag-version)) + +;;; Commentary: +;;; +;;; This module provides a generic package updater for packages hosted on Git +;;; repositories. +;;; +;;; It tries to be smart about tag names, but if it is not automatically able +;;; to parse the tag names correctly, users can set the `release-tag-prefix', +;;; `release-tag-suffix' and `release-tag-version-delimiter' properties of the +;;; package to make the updater parse the Git tag name correctly. +;;; +;;; Possible improvements: +;;; +;;; * More robust method for trying to guess the delimiter. Maybe look at the +;;; previous version/tag combo to determine the delimiter. +;;; +;;; * Differentiate between "normal" versions, e.g., 1.2.3, and dates, e.g., +;;; 2021.12.31. Honor a `release-tag-date-scheme?' property? +;;; +;;; Code: + +;;; Errors & warnings + +(define-condition-type &git-no-valid-tags-error &error + git-no-valid-tags-error?) + +(define (git-no-valid-tags-error) + (raise (condition (&message (message "no valid tags found")) + (&git-no-valid-tags-error)))) + +(define-condition-type &git-no-tags-error &error + git-no-tags-error?) + +(define (git-no-tags-error) + (raise (condition (&message (message "no tags were found")) + (&git-no-tags-error)))) + + +;;; Updater + +(define %pre-release-words + '("alpha" "beta" "rc" "dev" "test" "pre")) + +(define %pre-release-rx + (map (lambda (word) + (make-regexp (string-append ".+" word) regexp/icase)) + %pre-release-words)) + +(define* (version-mapping tags #:key prefix suffix delim pre-releases?) + "Given a list of Git TAGS, return an association list where the car is the +version corresponding to the tag, and the cdr is the name of the tag." + (define (guess-delimiter) + (let ((total (length tags)) + (dots (reduce + 0 (map (cut string-count <> #\.) tags))) + (dashes (reduce + 0 (map (cut string-count <> #\-) tags))) + (underscores (reduce + 0 (map (cut string-count <> #\_) tags)))) + (cond + ((>= dots (* total 0.35)) ".") + ((>= dashes (* total 0.8)) "-") + ((>= underscores (* total 0.8)) "_") + (else "")))) + + (define delim-rx (regexp-quote (or delim (guess-delimiter)))) + (define suffix-rx (string-append (or suffix "") "$")) + (define prefix-rx (string-append "^" (or prefix "[^[:digit:]]*"))) + (define pre-release-rx + (if pre-releases? + (string-append "(.*(" (string-join %pre-release-words "|") ").*)") + "")) + + (define tag-rx + (string-append prefix-rx "([[:digit:]][^" delim-rx "[:punct:]]*" + "(" delim-rx "[^[:punct:]" delim-rx "]+)" + ;; If there are no delimiters, it could mean that the + ;; version just contains one number (e.g., "2"), thus, use + ;; "*" instead of "+" to match zero or more numbers. + (if (string=? delim-rx "") "*" "+") ")" + ;; We don't want the pre-release stuff (e.g., "-alpha") be + ;; part of the first group; otherwise, the "-" in "-alpha" + ;; might be interpreted as a delimiter, and thus replaced + ;; with "." + pre-release-rx suffix-rx)) + + + + (define (get-version tag) + (let ((tag-match (regexp-exec (make-regexp tag-rx) tag))) + (and=> (and tag-match + (regexp-substitute/global + #f delim-rx (match:substring tag-match 1) + ;; If there were no delimiters, don't insert ".". + 'pre (if (string=? delim-rx "") "" ".") 'post)) + (lambda (version) + (if pre-releases? + (string-append version (match:substring tag-match 3)) + version))))) + + (define (entry tag) + %pre-release-rx)) + + (let* ((tags (map (cut string-drop <> (string-length "refs/tags/")) + (remote-refs url #:tags? #t))) + (versions->tags + (version-mapping (if pre-releases? + tags + (filter (negate pre-release?) tags)) + #:prefix prefix + #:suffix suffix + #:delim delim + #:pre-releases? pre-releases?))) + (cond + ((null? tags) + (git-no-tags-error)) + ((null? versions->tags) + (git-no-valid-tags-error)) + (else + (match (last versions->tags) + ((version . tag) + (values version tag))))))) + +(define (latest-git-tag-version package) + "Given a PACKAGE, return the latest version of it, or #f if the latest version +could not be determined." + (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c)) + (warning (or (package-field-location package 'source) + (package-location package)) + (G_ "~a for ~a~%") + (condition-message c) + (package-name package)) + #f) + ((eq? (exception-kind c) 'git-error) + (warning (or (package-field-location package 'source) + (package-location package)) + (G_ "failed to fetch Git repository for ~a~%") + (package-name package)) + #f)) + (let* ((source (package-source package)) + (url (git-reference-url (origin-uri source))) + (property (cute assq-ref (package-properties package) <>))) + (latest-tag url + #:prefix (property 'release-tag-prefix) + #:suffix (property 'release-tag-suffix) + #:delim (property 'release-tag-version-delimiter) + #:pre-releases? (property 'accept-pre-releases?))))) + +(define (git-package? package) + "Return true if PACKAGE is hosted on a Git repository." + (match (package-source package) + ((? origin? origin) + (and (eq? (origin-method origin) git-fetch) + (git-reference? (origin-uri origin)))) + (_ #f))) + +(define (latest-git-release package) + "Return an for the latest release of PACKAGE." + (let* ((name (package-name package)) + (old-version (package-version package)) + (url (git-reference-url (origin-uri (package-source package)))) + (new-version (latest-git-tag-version package))) + + (and new-version + (upstream-source + (package name) + (version new-version) + (urls (list url)))))) + +(define %generic-git-updater + (upstream-updater + (name 'generic-git) + (description "Updater for packages hosted on Git repositories") + (pred git-package?) + (latest latest-git-release))) diff --git a/tests/git.scm b/tests/git.scm index aa4f03ca62..d0646bbc85 100644 --- a/tests/git.scm +++ b/tests/git.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019, 2020 Ludovic Courtès +;;; Copyright © 2021 Xinglu Chen . + +(define-module (test-import-git) + #:use-module (git) + #:use-module (guix git) + #:use-module (guix tests) + #:use-module (guix packages) + #:use-module (guix import git) + #:use-module (guix git-download) + #:use-module (guix tests git) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +;; Test the (guix import git) tools. + +(test-begin "git") + +(define* (make-package directory version #:optional (properties '())) + (dummy-package "test-package" + (version version) + (properties properties) + (source + (origin + (method git-fetch) + (uri (git-reference + (url (string-append "file://" directory)) + (commit version))) + (sha256 + (base32 + "0000000000000000000000000000000000000000000000000000")))))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: no custom prefix, suffix, and delimiter" + "1.0.1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "1.0.1" "Release 1.0.1")) + (let ((package (make-package directory "1.0.0"))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: custom prefix, no suffix and delimiter" + "1.0.1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "prefix-1.0.1" "Release 1.0.1")) + (let ((package (make-package directory "1.0.0" + '((release-tag-prefix . "prefix-"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: custom suffix, no prefix and delimiter" + "1.0.1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "1.0.1-suffix-123" "Release 1.0.1")) + (let ((package (make-package directory "1.0.0" + '((release-tag-suffix . "-suffix-[0-9]*"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: custom delimiter, no prefix and suffix" + "2021.09.07" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "2021-09-07" "Release 2021-09-07")) + (let ((package (make-package directory "2021-09-06" + '((release-tag-version-delimiter . "-"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: empty delimiter, no prefix and suffix" + "20210907" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "20210907" "Release 20210907")) + (let ((package (make-package directory "20210906" + '((release-tag-version-delimiter . ""))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: custom prefix and suffix, no delimiter" + "2.0.0" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "Release-2.0.0suffix-1" "Release 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((release-tag-prefix . "Release-") + (release-tag-suffix . "suffix-[0-9]"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: custom prefix, suffix, and delimiter" + "2.0.0" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "Release-2_0_0suffix-1" "Release 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((release-tag-prefix . "Release-") + (release-tag-suffix . "suffix-[0-9]") + (release-tag-version-delimiter . "_"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: only pre-releases available" + #f + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "2.0.0-rc1" "Release candidate for 2.0.0")) + (let ((package (make-package directory "1.0.0"))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases" + "2.0.0-rc1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "2.0.0-rc1" "Release candidate for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, and custom prefix" + "2.0.0-rc1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "version-2.0.0-rc1" "Release candidate for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-prefix . "version-"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix" + "2.0.0-rc1" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "2.0.0-rc1-suffix" "Release candidate for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-suffix . "-suffix"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, delimiter conflicts with pre-release part" + "2.0.0_alpha" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "2_0_0_alpha" "Alpha release for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-version-delimiter . "_"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix and prefix" + "2.0.0-alpha" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "prefix123-2.0.0-alpha-suffix" "Alpha release for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-prefix . "prefix[0-9]{3}-") + (release-tag-suffix . "-suffix"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, and custom suffix, prefix, and delimiter" + "2.0.0-alpha" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "prefix123-2-0-0-alpha-suffix" "Alpha release for 2.0.0")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-prefix . "prefix[0-9]{3}-") + (release-tag-suffix . "-suffix") + (release-tag-version-delimiter . "-"))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: accept pre-releases, no delimiter, and custom suffix, prefix" + "2alpha" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "prefix123-2alpha-suffix" "Alpha release for version 2")) + (let ((package (make-package directory "1.0.0" + '((accept-pre-releases? . #t) + (release-tag-prefix . "prefix[0-9]{3}-") + (release-tag-suffix . "-suffix") + (release-tag-version-delimiter . ""))))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: no tags found" + #f + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit")) + (let ((package (make-package directory "1.0.0"))) + (latest-git-tag-version package)))) + +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-git-tag-version: no valid tags found" + #f + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "First commit") + (tag "Test" "Test tag")) + (let ((package (make-package directory "1.0.0"))) + (latest-git-tag-version package)))) + +(test-end "git") -- cgit 1.4.1 From 778c1fb4eabbb48c05f6c7555c89466d5249ebce Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 18 Sep 2021 19:32:37 +0200 Subject: channels: 'channel-news-entry-commit' correctly resolves annotated tags. Previously, 'channel-news-entry-commit' would return the tag ID rather than the commit ID when the news entry was referred to via an annotated tag. Reported by Xinglu Chen . * guix/channels.scm (resolve-channel-news-entry-tag): Check whether the reference points to annotated tag; resolve it if it does. * tests/channels.scm ("channel-news, annotated tag"): New test. --- guix/channels.scm | 9 +++++++-- tests/channels.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 54 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/guix/channels.scm b/guix/channels.scm index 476d62e1f4..e4e0428eb5 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -1089,8 +1089,13 @@ cannot be found." (if (channel-news-entry-commit entry) entry (let* ((tag (channel-news-entry-tag entry)) - (reference (string-append "refs/tags/" tag)) - (oid (reference-name->oid repository reference))) + (reference (reference-lookup repository + (string-append "refs/tags/" tag))) + (target (reference-target reference)) + (oid (let ((obj (object-lookup repository target))) + (if (= OBJ-TAG (object-type obj)) ;annotated tag? + (tag-target-id (tag-lookup repository target)) + target)))) (channel-news-entry (oid->string oid) tag (channel-news-entry-title entry) (channel-news-entry-body entry))))) diff --git a/tests/channels.scm b/tests/channels.scm index 0264369d9e..3e82315b0c 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -407,6 +407,53 @@ (channel-news-for-commit channel commit5 commit1)) '(#f "tag-for-first-news-entry"))))))) +(unless (which (git-command)) (test-skip 1)) +(test-assert "channel-news, annotated tag" + (with-temporary-git-repository directory + `((add ".guix-channel" + ,(object->string + '(channel (version 0) + (news-file "news.scm")))) + (add "src/a.txt" "A") + (commit "first commit") + (tag "tag-for-first-news-entry" + "This is an annotated tag.") + (add "news.scm" + ,(lambda (repository) + (let ((previous + (reference-name->oid repository "HEAD"))) + (object->string + `(channel-news + (version 0) + (entry (tag "tag-for-first-news-entry") + (title (en "New file!")) + (body (en "Yeah, a.txt.")))))))) + (commit "second commit")) + (with-repository directory repository + (define (find-commit* message) + (oid->string (commit-id (find-commit repository message)))) + + (let ((channel (channel (url (string-append "file://" directory)) + (name 'foo))) + (commit1 (find-commit* "first commit")) + (commit2 (find-commit* "second commit"))) + (and (null? (channel-news-for-commit channel commit1)) + (lset= equal? + (map channel-news-entry-title + (channel-news-for-commit channel commit2)) + '((("en" . "New file!")))) + (lset= string=? + (map channel-news-entry-tag + (channel-news-for-commit channel commit2)) + (list "tag-for-first-news-entry")) + ;; This is an annotated tag, but 'channel-news-entry-commit' + ;; should give us the commit ID, not the ID of the annotated tag + ;; object. + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit2)) + (list commit1))))))) + (unless (which (git-command)) (test-skip 1)) (test-assert "latest-channel-instances, missing introduction for 'guix'" (with-temporary-git-repository directory -- cgit 1.4.1 From 8d4c0e3104fdee7d2548077f9c338008b3595853 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Tue, 7 Sep 2021 13:03:12 +0200 Subject: tests/minetest: Fix 'test-package*' indenting. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * tests/minetest.scm (Local Variables)[test-package*]: Set scheme-indent-function property to 1. Signed-off-by: Ludovic Courtès --- tests/minetest.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'tests') diff --git a/tests/minetest.scm b/tests/minetest.scm index 6ae476fe5f..c6e872e918 100644 --- a/tests/minetest.scm +++ b/tests/minetest.scm @@ -353,3 +353,7 @@ during a dynamic extent where that package is available on ContentDB." (sort-packages (list x y z)))) (test-end "minetest") + +;;; Local Variables: +;;; eval: (put 'test-package* 'scheme-indent-function 1) +;;; End: -- cgit 1.4.1 From 8480a2a5bb360b432877dd33dca80a61c5a698eb Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Tue, 7 Sep 2021 13:05:56 +0200 Subject: import: minetest: Delete duplicate dependencies. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This fixes one of the issues noted in . * guix/import/minetest.scm (import-dependencies): Call 'delete-duplicates' on the resulting list. * tests/minetest.scm ("minetest->guix-package, multiple dependencies implemented by one mod"): New test. Signed-off-by: Ludovic Courtès --- guix/import/minetest.scm | 6 +++++- tests/minetest.scm | 10 ++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index e1f8487b75..c8209aba79 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -371,7 +371,11 @@ official Minetest forum and the Git repository (if any)." DEPENDENCIES as a list of AUTHOR/NAME strings." (define dependency-list (assoc-ref dependencies author/name)) - (filter-map + ;; A mod can have multiple dependencies implemented by the same mod, + ;; so remove duplicate mod names. + (define (filter-deduplicate-map f list) + (delete-duplicates (filter-map f list))) + (filter-deduplicate-map (lambda (dependency) (and (not (dependency-optional? dependency)) (not (builtin-mod? (dependency-name dependency))) diff --git a/tests/minetest.scm b/tests/minetest.scm index c6e872e918..80e2697a3d 100644 --- a/tests/minetest.scm +++ b/tests/minetest.scm @@ -331,6 +331,16 @@ during a dynamic extent where that package is available on ContentDB." "some-modpack/containing-mese"))) #:inputs '()) +;; See e.g. 'orwell/basic_trains' +(test-package* "minetest->guix-package, multiple dependencies implemented by one mod" + (list #:name "frobnicate" + #:guix-name "minetest-frobnicate" + #:upstream-name "Author/frobnicate" + #:requirements '(("frob" #f ("Author/frob")) + ("frob_x" #f ("Author/frob"))) + #:inputs '("minetest-frob")) + (list #:author "Author" #:name "frob")) + ;; License (test-package "minetest->guix-package, identical licenses" -- cgit 1.4.1 From 808f9ffbd3106da4c92d2367b118b98196c9e81e Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Tue, 7 Sep 2021 13:24:24 +0200 Subject: import: minetest: Strip "v" prefixes from the version number. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This fixes one of the issues noted at . * guix/import/minetest.scm (release-version): New procedure. (%minetest->guix-package): Call new procedure instead of release-title. * tests/minetest.scm (make-package-sexp): Allow overriding the version number. (make-releases-json): Allow overriding the release title. ("conventional version number") ("v-prefixed version number") ("dates as version number"): New tests. Signed-off-by: Ludovic Courtès --- guix/import/minetest.scm | 10 +++++++++- tests/minetest.scm | 23 ++++++++++++++++++----- 2 files changed, 27 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index c8209aba79..29bf12d123 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -337,6 +337,14 @@ official Minetest forum and the Git repository (if any)." (and=> (package-forums package) topic->url-sexp) (package-repository package))) +(define (release-version release) + "Guess the version of RELEASE from the release title." + (define title (release-title release)) + (if (string-prefix? "v" title) + ;; Remove "v" prefix from release titles like ‘v1.0.1’. + (substring title 1) + title)) + ;; If the default sort key is changed, make sure to modify 'show-help' ;; in (guix scripts import minetest) appropriately as well. (define %default-sort-key "score") @@ -436,7 +444,7 @@ list of AUTHOR/NAME strings." (define important-upstream-dependencies (important-dependencies dependencies author/name #:sort sort)) (values (make-minetest-sexp author/name - (release-title release) ; version + (release-version release) (package-repository package) (release-commit release) important-upstream-dependencies diff --git a/tests/minetest.scm b/tests/minetest.scm index 80e2697a3d..6998c9a70b 100644 --- a/tests/minetest.scm +++ b/tests/minetest.scm @@ -33,6 +33,10 @@ (define* (make-package-sexp #:key (guix-name "minetest-foo") + ;; This is not a proper version number but + ;; ContentDB often does not include version + ;; numbers. + (version "2021-07-25") (home-page "https://example.org/foo") (repo "https://example.org/foo.git") (synopsis "synopsis") @@ -44,9 +48,7 @@ #:allow-other-keys) `(package (name ,guix-name) - ;; This is not a proper version number but ContentDB does not include - ;; version numbers. - (version "2021-07-25") + (version ,version) (source (origin (method git-fetch) @@ -106,14 +108,14 @@ author "/" name "/download/")) ("website" . ,website))) -(define* (make-releases-json #:key (commit #f) (title "") #:allow-other-keys) +(define* (make-releases-json #:key (commit #f) (title "2021-07-25") #:allow-other-keys) `#((("commit" . ,commit) ("downloads" . 469) ("id" . 8614) ("max_minetest_version" . null) ("min_minetest_version" . null) ("release_date" . "2021-07-25T01:10:23.207584") - ("title" . "2021-07-25")))) + ("title" . ,title)))) (define* (make-dependencies-json #:key (author "Author") (name "foo") @@ -292,6 +294,17 @@ during a dynamic extent where that package is available on ContentDB." #:website 'null #:repo 'null) + +;; Determining the version number + +(test-package "conventional version number" #:version "1.2.3" #:title "1.2.3") +;; See e.g. orwell/basic_trains +(test-package "v-prefixed version number" #:version "1.2.3" #:title "v1.2.3") +;; Many mods on ContentDB use dates as release titles. In that case, the date +;; will have to do. +(test-package "dates as version number" + #:version "2021-01-01" #:title "2021-01-01") + ;; Dependencies -- cgit 1.4.1 From 5b32ad4f6f555d305659cee825879df075b06331 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Sep 2021 10:13:15 +0200 Subject: graph: Add '--max-depth'. * guix/graph.scm (export-graph): Add #:max-depth and honor it, adding 'depths' argument to 'loop'. * guix/scripts/graph.scm (%options, show-help): Add '--max-depth'. (%default-options): Add 'max-depth'. (guix-graph): Pass #:max-depth to 'export-graph'. * tests/graph.scm ("package DAG, limited depth"): New test. * doc/guix.texi (Invoking guix graph): Document it. --- doc/guix.texi | 14 ++++++++++++++ guix/graph.scm | 45 ++++++++++++++++++++++++++++----------------- guix/scripts/graph.scm | 11 ++++++++++- tests/graph.scm | 21 ++++++++++++++++++++- 4 files changed, 72 insertions(+), 19 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index cd8e249ae8..b15a45a977 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -12644,6 +12644,20 @@ $ guix graph --path -t references emacs libunistring /gnu/store/@dots{}-libunistring-0.9.10 @end example +Sometimes you still want to visualize the graph but would like to trim +it so it can actually be displayed. One way to do it is via the +@option{--max-depth} (or @option{-M}) option, which lets you specify the +maximum depth of the graph. In the example below, we visualize only +@code{libreoffice} and the nodes whose distance to @code{libreoffice} is +at most 2: + +@example +guix graph -M 2 libreoffice | xdot -f fdp - +@end example + +Mind you, that's still a big ball of spaghetti, but at least +@command{dot} can render it quickly and it can be browsed somewhat. + The available options are the following: @table @option diff --git a/guix/graph.scm b/guix/graph.scm index 0d4cd83667..3a1cab244b 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -337,11 +337,12 @@ nodeArray.push(nodes[\"~a\"]);~%" (define* (export-graph sinks port #:key - reverse-edges? node-type + reverse-edges? node-type (max-depth +inf.0) (backend %graphviz-backend)) "Write to PORT the representation of the DAG with the given SINKS, using the given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is -true, draw reverse arrows." +true, draw reverse arrows. Do not represent nodes whose distance to one of +the SINKS is greater than MAX-DEPTH." (match backend (($ _ _ emit-prologue emit-epilogue emit-node emit-edge) (emit-prologue (node-type-name node-type) port) @@ -349,6 +350,7 @@ true, draw reverse arrows." (match node-type (($ node-identifier node-label node-edges) (let loop ((nodes sinks) + (depths (make-list (length sinks) 0)) (visited (set))) (match nodes (() @@ -356,20 +358,29 @@ true, draw reverse arrows." (emit-epilogue port) (store-return #t))) ((head . tail) - (mlet %store-monad ((id (node-identifier head))) - (if (set-contains? visited id) - (loop tail visited) - (mlet* %store-monad ((dependencies (node-edges head)) - (ids (mapm %store-monad - node-identifier - dependencies))) - (emit-node id (node-label head) port) - (for-each (lambda (dependency dependency-id) - (if reverse-edges? - (emit-edge dependency-id id port) - (emit-edge id dependency-id port))) - dependencies ids) - (loop (append dependencies tail) - (set-insert id visited))))))))))))) + (match depths + ((depth . depths) + (mlet %store-monad ((id (node-identifier head))) + (if (set-contains? visited id) + (loop tail depths visited) + (mlet* %store-monad ((dependencies + (if (= depth max-depth) + (return '()) + (node-edges head))) + (ids + (mapm %store-monad + node-identifier + dependencies))) + (emit-node id (node-label head) port) + (for-each (lambda (dependency dependency-id) + (if reverse-edges? + (emit-edge dependency-id id port) + (emit-edge id dependency-id port))) + dependencies ids) + (loop (append dependencies tail) + (append (make-list (length dependencies) + (+ 1 depth)) + depths) + (set-insert id visited))))))))))))))) ;;; graph.scm ends here diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 66de824ef4..439fae0b52 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -500,6 +500,10 @@ package modules, while attempting to retain user package modules." (lambda (opt name arg result) (alist-cons 'backend (lookup-backend arg) result))) + (option '(#\M "max-depth") #t #f + (lambda (opt name arg result) + (alist-cons 'max-depth (string->number* arg) + result))) (option '("list-backends") #f #f (lambda (opt name arg result) (list-backends) @@ -537,6 +541,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) -t, --type=TYPE represent nodes of the given TYPE")) (display (G_ " --list-types list the available graph types")) + (display (G_ " + --max-depth=DEPTH limit to nodes within distance DEPTH")) (display (G_ " --path display the shortest path between the given nodes")) (display (G_ " @@ -559,6 +565,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (define %default-options `((node-type . ,%package-node-type) (backend . ,%graphviz-backend) + (max-depth . +inf.0) (system . ,(%current-system)))) @@ -582,6 +589,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (with-store store (let* ((transform (options->transformation opts)) + (max-depth (assoc-ref opts 'max-depth)) (items (filter-map (match-lambda (('argument . (? store-path? item)) item) @@ -613,7 +621,8 @@ nodes (given ~a)~%") (export-graph (concatenate nodes) (current-output-port) #:node-type type - #:backend backend))) + #:backend backend + #:max-depth max-depth))) #:system (assq-ref opts 'system))))) #t) diff --git a/tests/graph.scm b/tests/graph.scm index e374dad1a5..fadac265f9 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -94,6 +94,25 @@ edges." (list p3 p3 p2) (list p2 p1 p1)))))))) +(test-assert "package DAG, limited depth" + (let-values (((backend nodes+edges) (make-recording-backend))) + (let* ((p1 (dummy-package "p1")) + (p2 (dummy-package "p2" (inputs `(("p1" ,p1))))) + (p3 (dummy-package "p3" (inputs `(("p1" ,p1))))) + (p4 (dummy-package "p4" (inputs `(("p2" ,p2) ("p3" ,p3)))))) + (run-with-store %store + (export-graph (list p4) 'port + #:max-depth 1 + #:node-type %package-node-type + #:backend backend)) + ;; We should see nothing more than these 3 packages. + (let-values (((nodes edges) (nodes+edges))) + (and (equal? nodes (map package->tuple (list p4 p2 p3))) + (equal? edges + (map edge->tuple + (list p4 p4) + (list p2 p3)))))))) + (test-assert "reverse package DAG" (let-values (((backend nodes+edges) (make-recording-backend))) (run-with-store %store -- cgit 1.4.1 From 770ae098604d0bd9f21d625e8959e6c7ced3c36f Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Mon, 27 Sep 2021 16:15:40 +0200 Subject: tests: go: Fix typo. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * tests/go.scm (fixture-go-mod-unparseable): Rename this… (fixture-go-mod-unparsable): …to this. Adjust the only caller. --- tests/go.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/tests/go.scm b/tests/go.scm index 9e7223ff7c..a70a0ddbf5 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -99,7 +99,7 @@ replace ( ") -(define fixture-go-mod-unparseable +(define fixture-go-mod-unparsable "module my/thing go 1.12 // avoid feature X require other/thing v1.0.2 @@ -263,7 +263,7 @@ require github.com/kr/pretty v0.2.1 (with (module-path "good/thing") (version "v1.4.5")))) (parse-go.mod fixture-go-mod-simple)) -(test-equal "parse-go.mod: comments and unparseable lines" +(test-equal "parse-go.mod: comments and unparsable lines" `((module (module-path "my/thing")) (go (version "1.12") (comment "avoid feature X")) (require (module-path "other/thing") (version "v1.0.2")) @@ -274,7 +274,7 @@ require github.com/kr/pretty v0.2.1 (with (module-path "good/thing") (version "v1.4.5"))) (comment "Unparseable") (unknown "bad/thing [v1.4.5, v1.9.7] => good/thing v2.0.0")) - (parse-go.mod fixture-go-mod-unparseable)) + (parse-go.mod fixture-go-mod-unparsable)) (test-equal "parse-go.mod: retract" `((retract (version "v0.9.1")) -- cgit 1.4.1 From 2f5368d678aad334149b280e9dab90ec1635104b Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Mon, 27 Sep 2021 16:06:31 +0200 Subject: import: minetest: Fix typos. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/minetest.scm (elaborate-contentdb-name): Fix ‘ambiguous’ and ‘thes’ typos. * tests/minetest.scm: Likewise for all tests. --- guix/import/minetest.scm | 4 ++-- tests/minetest.scm | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index 29bf12d123..ba86c60bfd 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -203,7 +203,7 @@ raise an exception." (match correctly-named ((one) (package-keys-full-name one)) ((too . many) - (warning (G_ "~a is ambigious, presuming ~a (other options include: ~a)~%") + (warning (G_ "~a is ambiguous, presuming ~a (other options include: ~a)~%") name (package-keys-full-name too) (map package-keys-full-name many)) (package-keys-full-name too)) @@ -256,7 +256,7 @@ and possibly some other packages as well, or #f on failure." (order "desc")) "Search ContentDB for Q (a string). Sort by SORT, in ascending order if ORDER is \"asc\" or descending order if ORDER is \"desc\". TYPE must -be \"mod\", \"game\" or \"txp\", restricting thes search results to +be \"mod\", \"game\" or \"txp\", restricting the search results to respectively mods, games and texture packs. Limit to at most LIMIT results. The return value is a list of records." ;; XXX does Guile have something for constructing (and, when necessary, diff --git a/tests/minetest.scm b/tests/minetest.scm index 6998c9a70b..abb26d0a03 100644 --- a/tests/minetest.scm +++ b/tests/minetest.scm @@ -249,14 +249,14 @@ during a dynamic extent where that package is available on ContentDB." #:guix-name "minetest-foo-bar" #:upstream-name "Author/foo_bar") -(test-equal "elaborate names, unambigious" +(test-equal "elaborate names, unambiguous" "Jeija/mesecons" (call-with-packages (cut elaborate-contentdb-name "mesecons") '(#:name "mesecons" #:author "Jeija") '(#:name "something" #:author "else"))) -(test-equal "elaborate name, ambigious (highest score)" +(test-equal "elaborate name, ambiguous (highest score)" "Jeija/mesecons" (call-with-packages ;; #:sort "score" is the default @@ -266,7 +266,7 @@ during a dynamic extent where that package is available on ContentDB." '(#:name "mesecons" #:author "Jeija" #:score 999))) -(test-equal "elaborate name, ambigious (most downloads)" +(test-equal "elaborate name, ambiguous (most downloads)" "Jeija/mesecons" (call-with-packages (cut elaborate-contentdb-name "mesecons" #:sort "downloads") @@ -308,7 +308,7 @@ during a dynamic extent where that package is available on ContentDB." ;; Dependencies -(test-package* "minetest->guix-package, unambigious dependency" +(test-package* "minetest->guix-package, unambiguous dependency" (list #:requirements '(("mesecons" #f ("Jeija/mesecons" "some-modpack/containing-mese"))) @@ -316,7 +316,7 @@ during a dynamic extent where that package is available on ContentDB." (list #:author "Jeija" #:name "mesecons") (list #:author "some-modpack" #:name "containing-mese" #:type "modpack")) -(test-package* "minetest->guix-package, ambigious dependency (highest score)" +(test-package* "minetest->guix-package, ambiguous dependency (highest score)" (list #:name "frobnicate" #:guix-name "minetest-frobnicate" #:upstream-name "Author/frobnicate" @@ -327,7 +327,7 @@ during a dynamic extent where that package is available on ContentDB." (list #:author "Author" #:name "foo" #:score 0) (list #:author "Author" #:name "bar" #:score 9999)) -(test-package* "minetest->guix-package, ambigious dependency (most downloads)" +(test-package* "minetest->guix-package, ambiguous dependency (most downloads)" (list #:name "frobnicate" #:guix-name "minetest-frobnicate" #:upstream-name "Author/frobnicate" -- cgit 1.4.1 From 50d24214191abefc6b8f6c881f9a91c1f818a650 Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Tue, 28 Sep 2021 20:34:25 +0200 Subject: test: lint: Fix ‘haskell-stackage’ test. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a follow-up to commit 9c5e5ca1c0de56a0d5b2b924de10548172095b58. The previous package was called “ghc-x” which is not available on Stackage, instead change it to “ghc-pandoc” which does exist, and adjust its version. * tests/lint.scm ("haskell-stackage"): Add additional metadata for the package; change package name to “ghc-pandoc”; and change to version to “100.0”. Reported-by: Tobias Geerinckx-Rice Signed-off-by: Tobias Geerinckx-Rice --- tests/lint.scm | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/tests/lint.scm b/tests/lint.scm index 0f51b9ef79..e96265a55a 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1317,29 +1317,30 @@ (test-assert "haskell-stackage" (let* ((stackage (string-append "{ \"packages\": [{" - " \"name\":\"x\"," + " \"name\":\"pandoc\"," + " \"synopsis\":\"synopsis\"," " \"version\":\"1.0\" }]}")) (packages (map (lambda (version) (dummy-package - (string-append "ghc-x") + "ghc-pandoc" (version version) (source (dummy-origin (method url-fetch) (uri (string-append "https://hackage.haskell.org/package/" - "x-" version "/x-" version ".tar.gz")))))) - '("0.9" "1.0" "2.0"))) + "pandoc-" version "/pandoc-" version ".tar.gz")))))) + '("0.9" "1.0" "100.0"))) (warnings (pk (with-http-server `((200 ,stackage) ; memoized - (200 "name: x\nversion: 1.0\n") - (200 "name: x\nversion: 1.0\n") - (200 "name: x\nversion: 1.0\n")) + (200 "name: pandoc\nversion: 1.0\n") + (200 "name: pandoc\nversion: 1.0\n") + (200 "name: pandoc\nversion: 1.0\n")) (parameterize ((%hackage-url (%local-url)) (%stackage-url (%local-url))) (append-map check-haskell-stackage packages)))))) (match warnings (((? lint-warning? warning)) - (and (string=? (package-version (lint-warning-package warning)) "2.0") + (and (string=? (package-version (lint-warning-package warning)) "100.0") (string-contains (lint-warning-message warning) "ahead of Stackage LTS version")))))) -- cgit 1.4.1 From 7b75f90c5b0da896c486cae23d19d43e2a03bb56 Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Mon, 27 Sep 2021 22:11:20 +0200 Subject: import: pypi: Honor the 'upstream-name' package property. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously, when a PyPI package had a “-” followed by one or more digits in its name, e.g., “AV-98”, the importer would interpret “98” as the version of the package and thus mistake the “AV-98” package for the “av” package on PyPI. $ ./pre-inst-env guix refresh av-98 following redirection to `https://pypi.org/pypi/av/json'... /home/yoctocell/src/guix/gnu/packages/web-browsers.scm:914:13: av-98 would be upgraded from 1.0.1 to 8.0.3 Setting the ‘upstream-name’ property to “AV-98” would solve the problem. $ ./pre-inst-env guix refresh av-98 /home/yoctocell/src/guix/gnu/packages/web-browsers.scm:914:13: 1.0.1 is already the latest version of av-98 * guix/import/pypi.scm (guix-package->pypi-name): Honor ‘upstream-name’ property. (make-pypi-sexp): Set ‘upstream-name’ property when appropriate. * tests/pypi.scm (test-json): Rename to ... (test-json-1): ... this. (test-json-2): New variable ("guix-package->pypi-name, honor 'upstream-name'"): New test. ("pypi->guix-package, package name contains \"-\" followed by digits"): Likewise. Signed-off-by: Ludovic Courtès --- guix/import/pypi.scm | 20 +++++++--- tests/pypi.scm | 106 +++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 113 insertions(+), 13 deletions(-) (limited to 'tests') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 6731d50891..b7859c8341 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2020 Lars-Dominik Braun ;;; Copyright © 2020 Arun Isaac ;;; Copyright © 2020 Martin Becze +;;; Copyright © 2021 Xinglu Chen ;;; ;;; This file is part of GNU Guix. ;;; @@ -163,12 +164,13 @@ package on PyPI." (hyphen-package-name->name+version (basename (file-sans-extension url)))) - (match (and=> (package-source package) origin-uri) - ((? string? url) - (url->pypi-name url)) - ((lst ...) - (any url->pypi-name lst)) - (#f #f))) + (or (assoc-ref (package-properties package) 'upstream-name) + (match (and=> (package-source package) origin-uri) + ((? string? url) + (url->pypi-name url)) + ((lst ...) + (any url->pypi-name lst)) + (#f #f)))) (define (wheel-url->extracted-directory wheel-url) (match (string-split (basename wheel-url) #\-) @@ -423,6 +425,11 @@ return the unaltered list of upstream dependency names." description license) "Return the `package' s-expression for a python package with the given NAME, VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." + (define (maybe-upstream-name name) + (if (string-match ".*\\-[0-9]+" (pk name)) + `((properties ,`'(("upstream-name" . ,name)))) + '())) + (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) @@ -461,6 +468,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (sha256 (base32 ,(guix-hash-url temp))))) + ,@(maybe-upstream-name name) (build-system python-build-system) ,@(maybe-inputs required-inputs 'propagated-inputs) ,@(maybe-inputs native-inputs 'native-inputs) diff --git a/tests/pypi.scm b/tests/pypi.scm index f421d6d9df..70f4298a90 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014 David Thompson ;;; Copyright © 2016 Ricardo Wurmus ;;; Copyright © 2019 Maxim Cournoyer +;;; Copyright © 2021 Xinglu Chen ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,7 +30,7 @@ #:use-module (srfi srfi-64) #:use-module (ice-9 match)) -(define test-json +(define test-json-1 "{ \"info\": { \"version\": \"1.0.0\", @@ -57,6 +58,34 @@ } }") +(define test-json-2 + "{ + \"info\": { + \"version\": \"1.0.0\", + \"name\": \"foo-99\", + \"license\": \"GNU LGPL\", + \"summary\": \"summary\", + \"home_page\": \"http://example.com\", + \"classifiers\": [], + \"download_url\": \"\" + }, + \"urls\": [], + \"releases\": { + \"1.0.0\": [ + { + \"url\": \"https://example.com/foo-99-1.0.0.egg\", + \"packagetype\": \"bdist_egg\" + }, { + \"url\": \"https://example.com/foo-99-1.0.0.tar.gz\", + \"packagetype\": \"sdist\" + }, { + \"url\": \"https://example.com/foo-99-1.0.0-py2.py3-none-any.whl\", + \"packagetype\": \"bdist_wheel\" + } + ] + } +}") + (define test-source-hash "") @@ -147,6 +176,13 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing' (uri (list "https://bitheap.org/cram/cram-0.7.tar.gz" (pypi-uri "cram" "0.7")))))))) +(test-equal "guix-package->pypi-name, honor 'upstream-name'" + "bar-3" + (guix-package->pypi-name + (dummy-package "foo" + (properties + '((upstream-name . "bar-3")))))) + (test-equal "specification->requirement-name" '("Fizzy" "PickyThing" "SomethingWithMarker" "requests" "pip") (map specification->requirement-name test-specifications)) @@ -198,8 +234,8 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing' (lambda (url . rest) (match url ("https://pypi.org/pypi/foo/json" - (values (open-input-string test-json) - (string-length test-json))) + (values (open-input-string test-json-1) + (string-length test-json-1))) ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f) (_ (error "Unexpected URL: " url))))) (match (pypi->guix-package "foo") @@ -264,8 +300,8 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing' (lambda (url . rest) (match url ("https://pypi.org/pypi/foo/json" - (values (open-input-string test-json) - (string-length test-json))) + (values (open-input-string test-json-1) + (string-length test-json-1))) ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f) (_ (error "Unexpected URL: " url))))) ;; Not clearing the memoization cache here would mean returning the value @@ -317,8 +353,8 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing' (lambda (url . rest) (match url ("https://pypi.org/pypi/foo/json" - (values (open-input-string test-json) - (string-length test-json))) + (values (open-input-string test-json-1) + (string-length test-json-1))) ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f) (_ (error "Unexpected URL: " url))))) ;; Not clearing the memoization cache here would mean returning the value @@ -345,4 +381,60 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing' (x (pk 'fail x #f)))))) +(test-assert "pypi->guix-package, package name contains \"-\" followed by digits" + ;; Replace network resources with sample data. + (mock ((guix import utils) url-fetch + (lambda (url file-name) + (match url + ("https://example.com/foo-99-1.0.0.tar.gz" + (begin + ;; Unusual requires.txt location should still be found. + (mkdir-p "foo-99-1.0.0/src/bizarre.egg-info") + (with-output-to-file "foo-99-1.0.0/src/bizarre.egg-info/requires.txt" + (lambda () + (display test-requires.txt))) + (parameterize ((current-output-port (%make-void-port "rw+"))) + (system* "tar" "czvf" file-name "foo-99-1.0.0/")) + (delete-file-recursively "foo-99-1.0.0") + (set! test-source-hash + (call-with-input-file file-name port-sha256)))) + ("https://example.com/foo-99-1.0.0-py2.py3-none-any.whl" #f) + (_ (error "Unexpected URL: " url))))) + (mock ((guix http-client) http-fetch + (lambda (url . rest) + (match url + ("https://pypi.org/pypi/foo-99/json" + (values (open-input-string test-json-2) + (string-length test-json-2))) + ("https://example.com/foo-99-1.0.0-py2.py3-none-any.whl" #f) + (_ (error "Unexpected URL: " url))))) + (match (pypi->guix-package "foo-99") + (('package + ('name "python-foo-99") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri ('pypi-uri "foo-99" 'version)) + ('sha256 + ('base32 + (? string? hash))))) + ('properties ('quote (("upstream-name" . "foo-99")))) + ('build-system 'python-build-system) + ('propagated-inputs + ('quasiquote + (("python-bar" ('unquote 'python-bar)) + ("python-foo" ('unquote 'python-foo))))) + ('native-inputs + ('quasiquote + (("python-pytest" ('unquote 'python-pytest))))) + ('home-page "http://example.com") + ('synopsis "summary") + ('description "summary") + ('license 'license:lgpl2.0)) + (string=? (bytevector->nix-base32-string + test-source-hash) + hash)) + (x + (pk 'fail x #f)))))) + (test-end "pypi") -- cgit 1.4.1 From 46d15af4cb913d135c6e16c8cb713058aa9e2691 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 30 Sep 2021 22:38:57 +0200 Subject: import: stackage: Use 'define-json-mapping'. * guix/import/stackage.scm (, ) (): New record types and JSON mappings. (lts-info-packages, stackage-package-name) (stackage-package-version): Remove. (lts-package-version): Rename 'pkgs-info' to 'packages'; assume 'packages' is a list of . (stackage->guix-package): Use 'stackage-lts-packages' instead of 'lts-info-packages'. Rename 'packages-info' to 'packages'. (latest-lts-release): Likewise. (stackage-package?): Rename to... (stackage-lts-package?): ... this. Adjust to new API. (%stackage-updater)[pred]: Update accordingly. * tests/lint.scm ("haskell-stackage"): Add "snapshot" entry in JSON snippet. --- guix/import/stackage.scm | 79 +++++++++++++++++++++++++++--------------------- tests/lint.scm | 6 +++- 2 files changed, 49 insertions(+), 36 deletions(-) (limited to 'tests') diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 731e69651e..4eff09ad01 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2020 Martin Becze ;;; Copyright © 2021 Xinglu Chem +;;; Copyright © 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,13 +22,10 @@ (define-module (guix import stackage) #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 control) + #:use-module (json) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (srfi srfi-43) #:use-module (guix import json) #:use-module (guix import hackage) #:use-module (guix import utils) @@ -50,9 +48,28 @@ ;; Latest LTS version compatible with GHC 8.6.5. (define %default-lts-version "14.27") -(define (lts-info-packages lts-info) - "Returns the alist of packages contained in LTS-INFO." - (or (assoc-ref lts-info "packages") '())) +(define-json-mapping make-stackage-lts + stackage-lts? + json->stackage-lts + (snapshot stackage-lts-snapshot "snapshot" json->snapshot) + (packages stackage-lts-packages "packages" + (lambda (vector) + (map json->stackage-package (vector->list vector))))) + +(define-json-mapping make-snapshot + stackage-snapshot? + json->snapshot + (name snapshot-name) + (ghc-version snapshot-ghc-version) + (compiler snapshot-compiler)) + +(define-json-mapping make-stackage-package + stackage-package? + json->stackage-package + (origin stackage-package-origin) + (name stackage-package-name) + (version stackage-package-version) + (synopsis stackage-package-synopsis)) (define (leave-with-message fmt . args) (raise (condition (&message (message (apply format #f fmt args)))))) @@ -65,21 +82,14 @@ "/lts-" (if (string-null? version) %default-lts-version version))) - (lts-info (json-fetch url))) - (if lts-info - (reverse lts-info) + (lts-info (and=> (json-fetch url) json->stackage-lts))) + (or lts-info (leave-with-message "LTS release version not found: ~a" version)))))) -(define (stackage-package-name pkg-info) - (assoc-ref pkg-info "name")) - -(define (stackage-package-version pkg-info) - (assoc-ref pkg-info "version")) - -(define (lts-package-version pkgs-info name) - "Return the version of the package with upstream NAME included in PKGS-INFO." +(define (lts-package-version packages name) + "Return the version of the package with upstream NAME included in PACKAGES." (let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name)) - (vector->list pkgs-info)))) + packages))) (stackage-package-version pkg))) @@ -96,15 +106,15 @@ #:key (include-test-dependencies? #t) (lts-version %default-lts-version) - (packages-info - (lts-info-packages + (packages + (stackage-lts-packages (stackage-lts-info-fetch lts-version)))) "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION release at stackage.org. Return the `package' S-expression corresponding to that package, or #f on failure. PACKAGES-INFO is the alist with the packages included in the Stackage LTS release." - (let* ((version (lts-package-version packages-info package-name)) + (let* ((version (lts-package-version packages package-name)) (name-version (hackage-name-version package-name version))) (if name-version (hackage->guix-package name-version @@ -124,14 +134,15 @@ included in the Stackage LTS release." ;;; (define latest-lts-release - (let ((pkgs-info - (mlambda () (lts-info-packages - (stackage-lts-info-fetch %default-lts-version))))) + (let ((packages + (mlambda () + (stackage-lts-packages + (stackage-lts-info-fetch %default-lts-version))))) (lambda* (package) "Return an for the latest Stackage LTS release of PACKAGE or #f if the package is not included in the Stackage LTS release." (let* ((hackage-name (guix-package->hackage-name package)) - (version (lts-package-version (pkgs-info) hackage-name)) + (version (lts-package-version (packages) hackage-name)) (name-version (hackage-name-version hackage-name version))) (match (and=> name-version hackage-fetch) (#f (format (current-error-port) @@ -144,23 +155,21 @@ PACKAGE or #f if the package is not included in the Stackage LTS release." (version version) (urls (list url)))))))))) -(define (stackage-package? package) - "Whether PACKAGE is available on the default Stackage LTS release." +(define (stackage-lts-package? package) + "Return whether PACKAGE is available on the default Stackage LTS release." (and (hackage-package? package) - (let ((packages (lts-info-packages + (let ((packages (stackage-lts-packages (stackage-lts-info-fetch %default-lts-version))) (hackage-name (guix-package->hackage-name package))) - (vector-any identity - (vector-map - (lambda (_ metadata) - (string=? (cdr (list-ref metadata 2)) hackage-name)) - packages))))) + (find (lambda (package) + (string=? (stackage-package-name package) hackage-name)) + packages)))) (define %stackage-updater (upstream-updater (name 'stackage) (description "Updater for Stackage LTS packages") - (pred stackage-package?) + (pred stackage-lts-package?) (latest latest-lts-release))) ;;; stackage.scm ends here diff --git a/tests/lint.scm b/tests/lint.scm index e96265a55a..699a750eb9 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1319,7 +1319,11 @@ (let* ((stackage (string-append "{ \"packages\": [{" " \"name\":\"pandoc\"," " \"synopsis\":\"synopsis\"," - " \"version\":\"1.0\" }]}")) + " \"version\":\"1.0\" }]," + " \"snapshot\": {" + " \"ghc\": \"8.6.5\"," + " \"name\": \"lts-14.27\"" + " }}")) (packages (map (lambda (version) (dummy-package "ghc-pandoc" -- cgit 1.4.1 From 085a8a0cdfef7c414c92dcf2b0ea9aa970888a62 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Mon, 20 Sep 2021 15:27:08 +0200 Subject: import/minetest: Define an updater for mods on ContentDB. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Only detecting updates is currently supported. To actually perform the uppdates, a patch like is required. * guix/import/minetest.scm (version-style,minetest-package?,latest-minetest-release): New procedures. (%minetest-updater): New updater. * tests/minetest.scm (upstream-source->sexp,expected-sexp,example-package): New procedure. (test-release,test-no-release): New macro's. ("same version","new version (dotted)","new version (date)") ("new version (git -> dotted)","dotted->date","date->dotted") ("no commit informaton, no new release") ("minetest is not a minetest mod") ("technic is a minetest mod") ("upstream-name is required"): New tests. Signed-off-by: Ludovic Courtès --- guix/import/minetest.scm | 53 ++++++++++++++++++++- tests/minetest.scm | 120 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 172 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index ba86c60bfd..0f3ab473ca 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -25,6 +25,8 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module ((guix packages) #:prefix package:) + #:use-module (guix upstream) #:use-module (guix utils) #:use-module (guix ui) #:use-module (guix i18n) @@ -36,15 +38,19 @@ #:use-module (json) #:use-module (guix base32) #:use-module (guix git) + #:use-module ((guix git-download) #:prefix download:) #:use-module (guix store) #:export (%default-sort-key %contentdb-api json->package contentdb-fetch elaborate-contentdb-name + minetest-package? + latest-minetest-release minetest->guix-package minetest-recursive-import - sort-packages)) + sort-packages + %minetest-updater)) ;; The ContentDB API is documented at ;; . @@ -345,6 +351,17 @@ official Minetest forum and the Git repository (if any)." (substring title 1) title)) +(define (version-style version) + "Determine the kind of version number VERSION is -- a date, or a conventional +conventional version number." + (define dots? (->bool (string-index version #\.))) + (define hyphens? (->bool (string-index version #\-))) + (match (cons dots? hyphens?) + ((#true . #false) 'regular) ; something like "0.1" + ((#false . #false) 'regular) ; single component version number + ((#true . #true) 'regular) ; result of 'git-version' + ((#false . #true) 'date))) ; something like "2021-01-25" + ;; If the default sort key is changed, make sure to modify 'show-help' ;; in (guix scripts import minetest) appropriately as well. (define %default-sort-key "score") @@ -466,3 +483,37 @@ list of AUTHOR/NAME strings." (recursive-import author/name #:repo->guix-package minetest->guix-package* #:guix-name contentdb->package-name)) + +(define (minetest-package? pkg) + "Is PKG a Minetest mod on ContentDB?" + (and (string-prefix? "minetest-" (package:package-name pkg)) + (assq-ref (package:package-properties pkg) 'upstream-name))) + +(define (latest-minetest-release pkg) + "Return an for the latest release of the package PKG, +or #false if the latest release couldn't be determined." + (define author/name + (assq-ref (package:package-properties pkg) 'upstream-name)) + (define contentdb-package (contentdb-fetch author/name)) ; TODO warn if #f? + (define release (latest-release author/name)) + (define source (package:package-source pkg)) + (and contentdb-package release + (release-commit release) ; not always set + ;; Only continue if both the old and new version number are both + ;; dates or regular version numbers, as two different styles confuses + ;; the logic for determining which version is newer. + (eq? (version-style (release-version release)) + (version-style (package:package-version pkg))) + (upstream-source + (package (package:package-name pkg)) + (version (release-version release)) + (urls (list (download:git-reference + (url (package-repository contentdb-package)) + (commit (release-commit release)))))))) + +(define %minetest-updater + (upstream-updater + (name 'minetest) + (description "Updater for Minetest packages on ContentDB") + (pred minetest-package?) + (latest latest-minetest-release))) diff --git a/tests/minetest.scm b/tests/minetest.scm index abb26d0a03..77b9aa928f 100644 --- a/tests/minetest.scm +++ b/tests/minetest.scm @@ -17,10 +17,18 @@ ;;; along with GNU Guix. If not, see . (define-module (test-minetest) + #:use-module (guix build-system minetest) + #:use-module (guix upstream) #:use-module (guix memoization) #:use-module (guix import minetest) #:use-module (guix import utils) #:use-module (guix tests) + #:use-module (guix packages) + #:use-module (guix git-download) + #:use-module ((gnu packages minetest) + #:select (minetest minetest-technic)) + #:use-module ((gnu packages base) + #:select (hello)) #:use-module (json) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -375,8 +383,120 @@ during a dynamic extent where that package is available on ContentDB." (list z y x) (sort-packages (list x y z)))) + + +;; Update detection +(define (upstream-source->sexp upstream-source) + (define urls (upstream-source-urls upstream-source)) + (unless (= 1 (length urls)) + (error "only a single URL is expected")) + (define url (first urls)) + `(,(upstream-source-package upstream-source) + ,(upstream-source-version upstream-source) + ,(git-reference-url url) + ,(git-reference-commit url))) + +(define* (expected-sexp #:key + (repo "https://example.org/foo.git") + (guix-name "minetest-foo") + (new-version "0.8") + (commit "44941798d222901b8f381b3210957d880b90a2fc") + #:allow-other-keys) + `(,guix-name ,new-version ,repo ,commit)) + +(define* (example-package #:key + (source 'auto) + (repo "https://example.org/foo.git") + (old-version "0.8") + (commit "44941798d222901b8f381b3210957d880b90a2fc") + #:allow-other-keys) + (package + (name "minetest-foo") + (version old-version) + (source + (if (eq? source 'auto) + (origin + (method git-fetch) + (uri (git-reference + (url repo) + (commit commit #;"808f9ffbd3106da4c92d2367b118b98196c9e81e"))) + (sha256 #f) ; not important for the following tests + (file-name (git-file-name name version))) + source)) + (build-system minetest-mod-build-system) + (license #f) + (synopsis #f) + (description #f) + (home-page #f) + (properties '((upstream-name . "Author/foo"))))) + +(define-syntax-rule (test-release test-case . arguments) + (test-equal test-case + (expected-sexp . arguments) + (and=> + (call-with-packages + (cut latest-minetest-release (example-package . arguments)) + (list . arguments)) + upstream-source->sexp))) + +(define-syntax-rule (test-no-release test-case . arguments) + (test-equal test-case + #f + (call-with-packages + (cut latest-minetest-release (example-package . arguments)) + (list . arguments)))) + +(test-release "same version" + #:old-version "0.8" #:title "0.8" #:new-version "0.8" + #:commit "44941798d222901b8f381b3210957d880b90a2fc") + +(test-release "new version (dotted)" + #:old-version "0.8" #:title "0.9.0" #:new-version "0.9.0" + #:commit "c8855b991880897b2658dc90164e29c96e2aeb3a") + +(test-release "new version (date)" + #:old-version "2014-11-17" #:title "2015-11-04" + #:new-version "2015-11-04" + #:commit "c8855b991880897b2658dc90164e29c96e2aeb3a") + +(test-release "new version (git -> dotted)" + #:old-version + (git-version "0.8" "1" "90422555f114d3af35e7cc4b5b6d59a5c226adc4") + #:title "0.9.0" #:new-version "0.9.0" + #:commit "90422555f114d3af35e7cc4b5b6d59a5c226adc4") + +;; There might actually be a new release, but guix cannot compare dates +;; with regular version numbers. +(test-no-release "dotted -> date" + #:old-version "0.8" #:title "2015-11-04" + #:commit "c8855b991880897b2658dc90164e29c96e2aeb3a") + +(test-no-release "date -> dotted" + #:old-version "2014-11-07" #:title "0.8" + #:commit "c8855b991880897b2658dc90164e29c96e2aeb3a") + +;; Don't let "guix refresh -t minetest" tell there are new versions +;; if Guix has insufficient information to actually perform the update, +;; when using --with-latest or "guix refresh -u". +(test-no-release "no commit information, no new release" + #:old-version "0.8" #:title "0.9.0" #:new-version "0.9.0" + #:commit #false) + +(test-assert "minetest is not a minetest mod" + (not (minetest-package? minetest))) +(test-assert "GNU hello is not a minetest mod" + (not (minetest-package? hello))) +(test-assert "technic is a minetest mod" + (minetest-package? minetest-technic)) +(test-assert "upstream-name is required" + (not (minetest-package? + (package (inherit minetest-technic) + (properties '()))))) + (test-end "minetest") ;;; Local Variables: ;;; eval: (put 'test-package* 'scheme-indent-function 1) +;;; eval: (put 'test-release 'scheme-indent-function 1) +;;; eval: (put 'test-no-release 'scheme-indent-function 1) ;;; End: -- cgit 1.4.1 From 5e68f7a7b338951dcc227799a51c59d9ac77c696 Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Sat, 9 Oct 2021 14:52:13 +0300 Subject: tests: Add guix-home.sh. * tests/guix-home.sh: New file. * Makefile.am (SH_TESTS): Add this. --- Makefile.am | 1 + tests/guix-home.sh | 106 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 107 insertions(+) create mode 100644 tests/guix-home.sh (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index f2b6c8e8da..635147efc1 100644 --- a/Makefile.am +++ b/Makefile.am @@ -547,6 +547,7 @@ SH_TESTS = \ tests/guix-package-aliases.sh \ tests/guix-package-net.sh \ tests/guix-system.sh \ + tests/guix-home.sh \ tests/guix-archive.sh \ tests/guix-authenticate.sh \ tests/guix-environment.sh \ diff --git a/tests/guix-home.sh b/tests/guix-home.sh new file mode 100644 index 0000000000..0b5deabeb0 --- /dev/null +++ b/tests/guix-home.sh @@ -0,0 +1,106 @@ + +# GNU Guix --- Functional package management for GNU +# Copyright © 2021 Andrew Tropin +# Copyright © 2021 Oleg Pykhalov +# +# 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 . + +# +# Test the 'guix home' using the external store, if any. +# + +set -e + +guix home --version + +NIX_STORE_DIR="$(guile -c '(use-modules (guix config))(display %storedir)')" +localstatedir="$(guile -c '(use-modules (guix config))(display %localstatedir)')" +GUIX_DAEMON_SOCKET="$localstatedir/guix/daemon-socket/socket" +export NIX_STORE_DIR GUIX_DAEMON_SOCKET + +# Run tests only when a "real" daemon is available. +if ! guile -c '(use-modules (guix)) (exit (false-if-exception (open-connection)))' +then + exit 77 +fi + +STORE_PARENT="$(dirname "$NIX_STORE_DIR")" +export STORE_PARENT +if test "$STORE_PARENT" = "/"; then exit 77; fi + +test_directory="$(mktemp -d)" +trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT + +( + cd "$test_directory" || exit 77 + + HOME="$test_directory" + export HOME + + # + # Test 'guix home reconfigure'. + # + + cat > "home.scm" <<'EOF' +(use-modules (guix gexp) + (gnu home) + (gnu home services) + (gnu services)) + +(home-environment + (services + (list + (simple-service 'test-config + home-files-service-type + (list `("config/test.conf" + ,(plain-file + "tmp-file.txt" + "the content of ~/.config/test.conf"))))))) +EOF + + guix home reconfigure "${test_directory}/home.scm" + test -d "${HOME}/.guix-home" + grep -q "the content of ~/.config/test.conf" "${HOME}/.config/test.conf" + + # + # Test 'guix home describe'. + # + + configuration_file() + { + guix home describe \ + | grep 'configuration file:' \ + | cut -d : -f 2 \ + | xargs echo + } + test "$(cat "$(configuration_file)")" == "$(cat home.scm)" + + canonical_file_name() + { + guix home describe \ + | grep 'canonical file name:' \ + | cut -d : -f 2 \ + | xargs echo + } + test "$(canonical_file_name)" == "$(readlink "${HOME}/.guix-home")" + + # + # Test 'guix home search'. + # + + guix home search mcron | grep "^name: home-mcron" + guix home search job manager | grep "^name: home-mcron" +) -- cgit 1.4.1 From fee0bced7fec2f9950957976a28f033edd4f877c Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Sat, 2 Oct 2021 19:05:02 +0300 Subject: home: services: configuration: Support file-like objects. * gnu/home/services/configuration.scm (interpose): Operate only with file-like objects. (string-or-gexp?): Delete procedure. (serialize-string-or-gexp): Rename to 'serialize-file-like'. (text-config?): Call 'file-like' intead of 'string-or-gexp?'. * guix/scripts/home/import.scm: (generate-bash-module+configuration): Don't call slurp-file-gexp. * gnu/home/services/configuration.scm: Move content ... * gnu/services/configuration.scm: here. * gnu/home/services/shells.scm: Delete (gnu home services configuration). * gnu/home/services/xdg.scm: Same. * gnu/local.mk: Same. * tests/guix-home.sh: Test home-bash-service-type and extension with home-bash-extension. --- gnu/home/services/configuration.scm | 109 ------------------------------------ gnu/home/services/shells.scm | 1 - gnu/home/services/xdg.scm | 1 - gnu/local.mk | 1 - gnu/services/configuration.scm | 90 ++++++++++++++++++++++++++++- guix/scripts/home/import.scm | 8 +-- tests/guix-home.sh | 27 ++++++++- 7 files changed, 117 insertions(+), 120 deletions(-) delete mode 100644 gnu/home/services/configuration.scm (limited to 'tests') diff --git a/gnu/home/services/configuration.scm b/gnu/home/services/configuration.scm deleted file mode 100644 index 5e7743e7d6..0000000000 --- a/gnu/home/services/configuration.scm +++ /dev/null @@ -1,109 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Andrew Tropin -;;; Copyright © 2021 Xinglu Chen -;;; -;;; 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 . - -(define-module (gnu home services configuration) - #:use-module (gnu services configuration) - #:use-module (guix gexp) - #:use-module (srfi srfi-1) - #:use-module (ice-9 curried-definitions) - #:use-module (ice-9 match) - #:use-module (guix i18n) - #:use-module (guix diagnostics) - - #:export (filter-configuration-fields - - interpose - list-of - - list-of-strings? - alist? - string-or-gexp? - serialize-string-or-gexp - text-config? - serialize-text-config - generic-serialize-alist-entry - generic-serialize-alist)) - -(define* (filter-configuration-fields configuration-fields fields - #:optional negate?) - "Retrieve the fields listed in FIELDS from CONFIGURATION-FIELDS. -If NEGATE? is @code{#t}, retrieve all fields except FIELDS." - (filter (lambda (field) - (let ((member? (member (configuration-field-name field) fields))) - (if (not negate?) member? (not member?)))) - configuration-fields)) - - -(define* (interpose ls #:optional (delimiter "\n") (grammar 'infix)) - "Same as @code{string-join}, but without join and string, returns an -DELIMITER interposed LS. Support 'infix and 'suffix GRAMMAR values." - (when (not (member grammar '(infix suffix))) - (raise - (formatted-message - (G_ "The GRAMMAR value must be 'infix or 'suffix, but ~a provided.") - grammar))) - (fold-right (lambda (e acc) - (cons e - (if (and (null? acc) (eq? grammar 'infix)) - acc - (cons delimiter acc)))) - '() ls)) - -(define (list-of pred?) - "Return a procedure that takes a list and check if all the elements of -the list result in @code{#t} when applying PRED? on them." - (lambda (x) - (if (list? x) - (every pred? x) - #f))) - - -(define list-of-strings? - (list-of string?)) - -(define alist? list?) - -(define (string-or-gexp? sg) (or (string? sg) (gexp? sg))) -(define (serialize-string-or-gexp field-name val) "") - -(define (text-config? config) - (and (list? config) (every string-or-gexp? config))) -(define (serialize-text-config field-name val) - #~(string-append #$@(interpose val "\n" 'suffix))) - -(define ((generic-serialize-alist-entry serialize-field) entry) - "Apply the SERIALIZE-FIELD procedure on the field and value of ENTRY." - (match entry - ((field . val) (serialize-field field val)))) - -(define (generic-serialize-alist combine serialize-field fields) - "Generate a configuration from an association list FIELDS. - -SERIALIZE-FIELD is a procedure that takes two arguments, it will be -applied on the fields and values of FIELDS using the -@code{generic-serialize-alist-entry} procedure. - -COMBINE is a procedure that takes one or more arguments and combines -all the alist entries into one value, @code{string-append} or -@code{append} are usually good candidates for this. - -See the @code{serialize-alist} procedure in `@code{(gnu home-services -version-control}' for an example usage.)}" - (apply combine - (map (generic-serialize-alist-entry serialize-field) fields))) diff --git a/gnu/home/services/shells.scm b/gnu/home/services/shells.scm index 21b250f35d..1cd17b2c32 100644 --- a/gnu/home/services/shells.scm +++ b/gnu/home/services/shells.scm @@ -19,7 +19,6 @@ (define-module (gnu home services shells) #:use-module (gnu services configuration) - #:use-module (gnu home services configuration) #:use-module (gnu home services utils) #:use-module (gnu home services) #:use-module (gnu packages shells) diff --git a/gnu/home/services/xdg.scm b/gnu/home/services/xdg.scm index 453c05ddbf..20fb7f7b40 100644 --- a/gnu/home/services/xdg.scm +++ b/gnu/home/services/xdg.scm @@ -19,7 +19,6 @@ (define-module (gnu home services xdg) #:use-module (gnu services configuration) - #:use-module (gnu home services configuration) #:use-module (gnu home services) #:use-module (gnu packages freedesktop) #:use-module (gnu home services utils) diff --git a/gnu/local.mk b/gnu/local.mk index ff51c500d4..63ef645deb 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -77,7 +77,6 @@ GNU_SYSTEM_MODULES = \ %D%/home/services.scm \ %D%/home/services/symlink-manager.scm \ %D%/home/services/fontutils.scm \ - %D%/home/services/configuration.scm \ %D%/home/services/shells.scm \ %D%/home/services/shepherd.scm \ %D%/home/services/mcron.scm \ diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index df3d3b6f9b..e8c55b6e4d 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2017, 2018 Clément Lassieur ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2021 Maxim Cournoyer +;;; Copyright © 2021 Andrew Tropin ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,10 +26,12 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module ((guix utils) #:select (source-properties->location)) - #:use-module ((guix diagnostics) #:select (location-file)) + #:use-module ((guix diagnostics) #:select (formatted-message location-file)) #:use-module ((guix modules) #:select (file-name->module-name)) + #:use-module (guix i18n) #:autoload (texinfo) (texi-fragment->stexi) #:autoload (texinfo serialize) (stexi->texi) + #:use-module (ice-9 curried-definitions) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) @@ -56,7 +59,20 @@ generate-documentation configuration->documentation empty-serializer - serialize-package)) + serialize-package + + filter-configuration-fields + + interpose + list-of + + list-of-strings? + alist? + serialize-file-like + text-config? + serialize-text-config + generic-serialize-alist-entry + generic-serialize-alist)) ;;; Commentary: ;;; @@ -323,3 +339,73 @@ Texinfo documentation of its fields." '-fields)))) (display (generate-documentation `((,configuration-symbol ,fields-getter)) configuration-symbol)))) + +(define* (filter-configuration-fields configuration-fields fields + #:optional negate?) + "Retrieve the fields listed in FIELDS from CONFIGURATION-FIELDS. +If NEGATE? is @code{#t}, retrieve all fields except FIELDS." + (filter (lambda (field) + (let ((member? (member (configuration-field-name field) fields))) + (if (not negate?) member? (not member?)))) + configuration-fields)) + + +(define* (interpose ls #:optional (delimiter "\n") (grammar 'infix)) + "Same as @code{string-join}, but without join and string, returns an +DELIMITER interposed LS. Support 'infix and 'suffix GRAMMAR values." + (when (not (member grammar '(infix suffix))) + (raise + (formatted-message + (G_ "The GRAMMAR value must be 'infix or 'suffix, but ~a provided.") + grammar))) + (fold-right (lambda (e acc) + (cons #~(begin + (use-modules (ice-9 rdelim)) + (with-fluids ((%default-port-encoding "UTF-8")) + (with-input-from-file #$e read-string))) + (if (and (null? acc) (eq? grammar 'infix)) + acc + (cons delimiter acc)))) + '() ls)) + +(define (list-of pred?) + "Return a procedure that takes a list and check if all the elements of +the list result in @code{#t} when applying PRED? on them." + (lambda (x) + (if (list? x) + (every pred? x) + #f))) + + +(define list-of-strings? + (list-of string?)) + +(define alist? list?) + +(define serialize-file-like empty-serializer) + +(define (text-config? config) + (list-of file-like?)) +(define (serialize-text-config field-name val) + #~(string-append #$@(interpose val "\n" 'suffix))) + +(define ((generic-serialize-alist-entry serialize-field) entry) + "Apply the SERIALIZE-FIELD procedure on the field and value of ENTRY." + (match entry + ((field . val) (serialize-field field val)))) + +(define (generic-serialize-alist combine serialize-field fields) + "Generate a configuration from an association list FIELDS. + +SERIALIZE-FIELD is a procedure that takes two arguments, it will be +applied on the fields and values of FIELDS using the +@code{generic-serialize-alist-entry} procedure. + +COMBINE is a procedure that takes one or more arguments and combines +all the alist entries into one value, @code{string-append} or +@code{append} are usually good candidates for this. + +See the @code{serialize-alist} procedure in `@code{(gnu home services +version-control}' for an example usage.)}" + (apply combine + (map (generic-serialize-alist-entry serialize-field) fields))) diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm index c977ec3861..611f580e85 100644 --- a/guix/scripts/home/import.scm +++ b/guix/scripts/home/import.scm @@ -46,17 +46,15 @@ (home-bash-configuration ,@(if (file-exists? rc) `((bashrc - (list (slurp-file-gexp (local-file ,rc))))) + (list (local-file ,rc)))) '()) ,@(if (file-exists? profile) `((bash-profile - (list (slurp-file-gexp - (local-file ,profile))))) + (list (local-file ,profile)))) '()) ,@(if (file-exists? logout) `((bash-logout - (list (slurp-file-gexp - (local-file ,logout))))) + (list (local-file ,logout)))) '())))))) diff --git a/tests/guix-home.sh b/tests/guix-home.sh index 0b5deabeb0..e578559c97 100644 --- a/tests/guix-home.sh +++ b/tests/guix-home.sh @@ -54,10 +54,13 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT # Test 'guix home reconfigure'. # + printf "# dot-bashrc test file for guix home" > "dot-bashrc" + cat > "home.scm" <<'EOF' (use-modules (guix gexp) (gnu home) (gnu home services) + (gnu home services shells) (gnu services)) (home-environment @@ -68,11 +71,33 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT (list `("config/test.conf" ,(plain-file "tmp-file.txt" - "the content of ~/.config/test.conf"))))))) + "the content of ~/.config/test.conf")))) + + (service home-bash-service-type + (home-bash-configuration + (guix-defaults? #t) + (bashrc + (list + (local-file (string-append (dirname (current-filename)) + "/dot-bashrc")))))) + + (simple-service 'home-bash-service-extension-test + home-bash-service-type + (home-bash-extension + (bashrc + (list + (plain-file + "bashrc-test-config.sh" + "# the content of bashrc-test-config.sh")))))))) EOF guix home reconfigure "${test_directory}/home.scm" test -d "${HOME}/.guix-home" + test -h "${HOME}/.bash_profile" + test -h "${HOME}/.bashrc" + test "$(tail -n 2 "${HOME}/.bashrc")" == "\ +# dot-bashrc test file for guix home +# the content of bashrc-test-config.sh" grep -q "the content of ~/.config/test.conf" "${HOME}/.config/test.conf" # -- cgit 1.4.1