From f9c0400392843540a87985a67ffb9fb6e4dbc2fa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Sep 2019 14:55:44 +0200 Subject: guix package: "guix package -f FILE" ensures FILE returns a package. * guix/scripts/package.scm (options->installable): Add clause for 'install option with a non-package object. * tests/guix-package.sh: Add test. --- tests/guix-package.sh | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'tests') diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 79d6ec65e4..79e89286f1 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -331,6 +331,17 @@ cat > "$module_dir/package.scm"< "$module_dir/package.scm"< Date: Wed, 18 Sep 2019 15:11:40 +0200 Subject: linux-container: 'eval/container' correctly passes -L and -C flags. This fixes a type error. * gnu/system/linux-container.scm (eval/container): Use 'append-map', not 'map'. * tests/containers.scm ("eval/container, non-empty load path"): New test. --- gnu/system/linux-container.scm | 12 +++++++----- tests/containers.scm | 27 +++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 5 deletions(-) (limited to 'tests') diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index c6124cd223..2ab679ff3f 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -257,11 +257,13 @@ (define items (lowered-gexp-guile lowered)) "/bin/guile") "guile" - (append (map (lambda (directory) `("-L" ,directory)) - (lowered-gexp-load-path lowered)) - (map (lambda (directory) `("-C" ,directory)) - (lowered-gexp-load-compiled-path - lowered)) + (append (append-map (lambda (directory) + `("-L" ,directory)) + (lowered-gexp-load-path lowered)) + (append-map (lambda (directory) + `("-C" ,directory)) + (lowered-gexp-load-compiled-path + lowered)) (list "-c" (object->string (lowered-gexp-sexp lowered)))))))))))) diff --git a/tests/containers.scm b/tests/containers.scm index c6c738f234..01fbcbb45a 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -269,4 +269,31 @@ (define requisites* (lset= string=? (cons* "." ".." (map basename reqs)) (pk (call-with-input-file result read)))))))))) +(test-assert "eval/container, non-empty load path" + (call-with-temporary-directory + (lambda (directory) + (define store + (open-connection-for-tests)) + (define result + (string-append directory "/r")) + (define requisites* + (store-lift requisites)) + + (mkdir result) + (run-with-store store + (mlet %store-monad ((status (eval/container + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/result/a/b/c"))) + #:mappings + (list (file-system-mapping + (source result) + (target "/result") + (writable? #t)))))) + (close-connection store) + (return (and (zero? status) + (file-is-directory? + (string-append result "/a/b/c"))))))))) + (test-end) -- cgit v1.2.3 From d2cdef65605b9e14bfa02c3bf1612ab6b62f4a89 Mon Sep 17 00:00:00 2001 From: zimoun Date: Wed, 18 Sep 2019 17:57:57 +0200 Subject: ui: 'relevance' connects regexps with a logical and. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Previously, the logical and connecting the regexps did not output the expected results (introduced in 8874faaaac665100a095ef25e39c9a389f5a397f). * guix/ui.scm (relevance) [score]: Change its arguments. [regexp->score]: New procedure. * tests/ui.scm ("package-relevance"): Add test. Signed-off-by: Ludovic Courtès --- guix/ui.scm | 48 ++++++++++++++++++++++++------------------------ tests/ui.scm | 5 ++++- 2 files changed, 28 insertions(+), 25 deletions(-) (limited to 'tests') diff --git a/guix/ui.scm b/guix/ui.scm index 7920335928..4be31db047 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -13,6 +13,7 @@ ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2019 Chris Marusich ;;; Copyright © 2019 Tobias Geerinckx-Rice +;;; Copyright © 2019 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -1281,33 +1282,32 @@ (define (relevance obj regexps metrics) A score of zero means that OBJ does not match any of REGEXPS. The higher the score, the more relevant OBJ is to REGEXPS." - (define (score str) - (define scores - (map (lambda (regexp) - (fold-matches regexp str 0 - (lambda (m score) - (+ score - (if (string=? (match:substring m) str) - 5 ;exact match - 1))))) - regexps)) - + (define (score regexp str) + (fold-matches regexp str 0 + (lambda (m score) + (+ score + (if (string=? (match:substring m) str) + 5 ;exact match + 1))))) + + (define (regexp->score regexp) + (let ((score-regexp (lambda (str) (score regexp str)))) + (fold (lambda (metric relevance) + (match metric + ((field . weight) + (match (field obj) + (#f relevance) + ((? string? str) + (+ relevance (* (score-regexp str) weight))) + ((lst ...) + (+ relevance (* weight (apply + (map score-regexp lst))))))))) + 0 metrics))) + + (let ((scores (map regexp->score regexps))) ;; Return zero if one of REGEXPS doesn't match. (if (any zero? scores) 0 - (reduce + 0 scores))) - - (fold (lambda (metric relevance) - (match metric - ((field . weight) - (match (field obj) - (#f relevance) - ((? string? str) - (+ relevance (* (score str) weight))) - ((lst ...) - (+ relevance (* weight (apply + (map score lst))))))))) - 0 - metrics)) + (reduce + 0 scores)))) (define %package-metrics ;; Metrics used to compute the "relevance score" of a package against a set diff --git a/tests/ui.scm b/tests/ui.scm index 2138e23369..d8573e88d8 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -267,6 +267,7 @@ (define guile-2.0.9 (gcrypt (specification->package "guile-gcrypt")) (go (specification->package "go")) (gnugo (specification->package "gnugo")) + (libb2 (specification->package "libb2")) (rx (cut make-regexp <> regexp/icase)) (>0 (cut > <> 0)) (=0 zero?)) @@ -283,6 +284,8 @@ (define guile-2.0.9 (=0 (package-relevance go (map rx '("go" "game")))) (>0 (package-relevance gnugo - (map rx '("go" "game"))))))) + (map rx '("go" "game")))) + (>0 (package-relevance libb2 + (map rx '("crypto" "library"))))))) (test-end "ui") -- cgit v1.2.3 From 71507435225f10d8d944ba183cbcc77ef953e0e5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Sep 2019 22:26:53 +0200 Subject: inferior: Propagate '&store-protocol-error' error conditions. Until now '&store-protocol-error' conditions raised in the inferior would not be correctly propagated because SRFI-35 records lack a read syntax. Reported at by Carl Dong . * guix/inferior.scm (port->inferior): Import (srfi srfi-34) in the inferior. (inferior-eval-with-store): Define 'error?' and 'error-message'. Wrap call to PROC in 'guard'. Check the response of INFERIOR for a 'store-protocol-error' or a 'result' tag. * tests/inferior.scm ("inferior-eval-with-store, &store-protocol-error"): New test. --- guix/inferior.scm | 31 +++++++++++++++++++++++++++---- tests/inferior.scm | 13 +++++++++++++ 2 files changed, 40 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/guix/inferior.scm b/guix/inferior.scm index fee97750b6..6be30d3f17 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -19,6 +19,8 @@ (define-module (guix inferior) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module ((guix utils) #:select (%current-system source-properties->location @@ -29,7 +31,8 @@ (define-module (guix inferior) #:select (store-connection-socket store-connection-major-version store-connection-minor-version - store-lift)) + store-lift + &store-protocol-error)) #:use-module ((guix derivations) #:select (read-derivation-from-file)) #:use-module (guix gexp) @@ -151,6 +154,7 @@ (define* (port->inferior pipe #:optional (close close-port)) (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) (inferior-eval '(use-modules (ice-9 match)) result) + (inferior-eval '(use-modules (srfi srfi-34)) result) (inferior-eval '(define %package-table (make-hash-table)) result) result)) @@ -462,7 +466,13 @@ (define (inferior-eval-with-store inferior store code) (listen socket 1024) (send-inferior-request `(let ((proc ,code) - (socket (socket AF_UNIX SOCK_STREAM 0))) + (socket (socket AF_UNIX SOCK_STREAM 0)) + (error? (if (defined? 'store-protocol-error?) + store-protocol-error? + nix-protocol-error?)) + (error-message (if (defined? 'store-protocol-error-message) + store-protocol-error-message + nix-protocol-error-message))) (connect socket AF_UNIX ,name) ;; 'port->connection' appeared in June 2018 and we can hardly @@ -475,7 +485,13 @@ (define (inferior-eval-with-store inferior store code) (dynamic-wind (const #t) (lambda () - (proc store)) + ;; Serialize '&store-protocol-error' conditions. The + ;; exception serialization mechanism that + ;; 'read-repl-response' expects is unsuitable for SRFI-35 + ;; error conditions, hence this special case. + (guard (c ((error? c) + `(store-protocol-error ,(error-message c)))) + `(result ,(proc store)))) (lambda () (close-connection store) (close-port socket))))) @@ -484,7 +500,14 @@ (define (inferior-eval-with-store inferior store code) ((client . address) (proxy client (store-connection-socket store)))) (close-port socket) - (read-inferior-response inferior))))) + + (match (read-inferior-response inferior) + (('store-protocol-error message) + (raise (condition + (&store-protocol-error (message message) + (status 1))))) + (('result result) + result)))))) (define* (inferior-package-derivation store package #:optional diff --git a/tests/inferior.scm b/tests/inferior.scm index 71ebf8f59b..f54b6d6037 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -27,6 +27,7 @@ (define-module (test-inferior) #:use-module (gnu packages bootstrap) #:use-module (gnu packages guile) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -186,6 +187,18 @@ (define result (add-text-to-store store "foo" "Hello, world!"))))) +(test-assert "inferior-eval-with-store, &store-protocol-error" + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) + "invalid character"))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (add-text-to-store store "we|rd/?!@" + "uh uh"))) + #f))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3 From aeb51370da7c854e8167066df9b138e15d7363e6 Mon Sep 17 00:00:00 2001 From: zimoun Date: Thu, 19 Sep 2019 19:24:42 +0200 Subject: guix package: Add 'guix show' alias. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/show.scm: New file. * Makefile.am (MODULES): Add it. * po/guix/POTFILES.in: Add it. * tests/guix-package-aliases.sh: Add test. * doc/guix.texi (Invoking guix package): Document it and use it in a example. Signed-off-by: Ludovic Courtès --- Makefile.am | 1 + doc/guix.texi | 8 ++++-- guix/scripts/show.scm | 67 +++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + tests/guix-package-aliases.sh | 4 +++ 5 files changed, 78 insertions(+), 3 deletions(-) create mode 100644 guix/scripts/show.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 93d18d7df6..f71ea77671 100644 --- a/Makefile.am +++ b/Makefile.am @@ -241,6 +241,7 @@ MODULES = \ guix/scripts/remove.scm \ guix/scripts/upgrade.scm \ guix/scripts/search.scm \ + guix/scripts/show.scm \ guix/scripts/gc.scm \ guix/scripts/hash.scm \ guix/scripts/pack.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 0ed59072c9..af1903f6ff 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2657,7 +2657,9 @@ For your convenience, we also provide the following aliases: @item @command{guix remove} is an alias for @command{guix package -r}, @item -and @command{guix upgrade} is an alias for @command{guix package -u}. +@command{guix upgrade} is an alias for @command{guix package -u}, +@item +and @command{guix show} is an alias for @command{guix package --show=}. @end itemize These aliases are less expressive than @command{guix package} and provide @@ -3020,9 +3022,9 @@ version: 3.3.5 @end example You may also specify the full name of a package to only get details about a -specific version of it: +specific version of it (this time using the @command{guix show} alias): @example -$ guix package --show=python@@3.4 | recsel -p name,version +$ guix show python@@3.4 | recsel -p name,version name: python version: 3.4.3 @end example diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm new file mode 100644 index 0000000000..94f0559358 --- /dev/null +++ b/guix/scripts/show.scm @@ -0,0 +1,67 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Simon Tournier +;;; +;;; 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 scripts show) + #:use-module (guix ui) + #:use-module (guix scripts package) + #:use-module (guix scripts) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-show)) + +(define (show-help) + (display (G_ "Usage: guix show [OPTION] PACKAGE... +Show details about PACKAGE.")) + (display (G_" +This is an alias for 'guix package --show='.\n")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix show"))))) + +(define (guix-show . args) + (define (handle-argument arg result) + ;; Treat all non-option arguments as regexps. + (cons `(query show ,arg) + result)) + + (define opts + (args-fold* args %options + (lambda (opt name arg . rest) + (leave (G_ "~A: unrecognized option~%") name)) + handle-argument + '())) + + (unless (assoc-ref opts 'query) + (leave (G_ "missing arguments: no package to show~%"))) + + (guix-package* opts)) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 8b556ac0ec..f629034d61 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -47,6 +47,7 @@ guix/scripts/install.scm guix/scripts/remove.scm guix/scripts/upgrade.scm guix/scripts/search.scm +guix/scripts/show.scm guix/scripts/gc.scm guix/scripts/hash.scm guix/scripts/import.scm diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh index 5c68664093..9c038b99a5 100644 --- a/tests/guix-package-aliases.sh +++ b/tests/guix-package-aliases.sh @@ -58,3 +58,7 @@ if guix remove -i guile-bootstrap -p "$profile" --bootstrap then false; else true; fi guix search '\' game | grep '^name: gnubg' + +guix show --version +guix show guile +guix show python@3 | grep "^name: python" -- cgit v1.2.3 From 660dbe65641851aa99b810e4ae065a5f72dc37d0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Sep 2019 23:02:30 +0200 Subject: guix package: '--show' ignores deprecated packages. * guix/scripts/package.scm (process-query) <'show>: Remove superseded packages. * tests/guix-package-aliases.sh: Add test. --- guix/scripts/package.scm | 3 ++- tests/guix-package-aliases.sh | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 21737f43da..f03741aa9e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -764,7 +764,8 @@ (define (diff-profiles profile numbers) (('show requested-name) (let-values (((name version) (package-name->name+version requested-name))) - (match (find-packages-by-name name version) + (match (remove package-superseded + (find-packages-by-name name version)) (() (leave (G_ "~a~@[@~a~]: package not found~%") name version)) (packages diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh index 9c038b99a5..4beed2e5b7 100644 --- a/tests/guix-package-aliases.sh +++ b/tests/guix-package-aliases.sh @@ -62,3 +62,6 @@ guix search '\' game | grep '^name: gnubg' guix show --version guix show guile guix show python@3 | grep "^name: python" + +# "python@2" exists but is deprecated; make sure it doesn't show up. +if guix show python@2; then false; else true; fi -- cgit v1.2.3 From 873f6f1334ab06a69e768a8aea0054404237542f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Sep 2019 17:54:06 +0200 Subject: git: Add 'commit-difference'. * guix/git.scm (commit-closure, commit-difference): New procedures. * guix/tests/git.scm, tests/git.scm: New files. * Makefile.am (dist_noinst_DATA): Add guix/tests/git.scm. (SCM_TESTS): Add tests/git.scm. --- .dir-locals.el | 1 + Makefile.am | 6 +++- guix/git.scm | 40 ++++++++++++++++++++++ guix/tests/git.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/git.scm | 99 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 242 insertions(+), 1 deletion(-) create mode 100644 guix/tests/git.scm create mode 100644 tests/git.scm (limited to 'tests') diff --git a/.dir-locals.el b/.dir-locals.el index 228685a69f..22aac2c402 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -90,6 +90,7 @@ (eval . (put 'eventually 'scheme-indent-function 1)) (eval . (put 'call-with-progress-reporter 'scheme-indent-function 1)) + (eval . (put 'with-temporary-git-repository 'scheme-indent-function 2)) ;; This notably allows '(' in Paredit to not insert a space when the ;; preceding symbol is one of these. diff --git a/Makefile.am b/Makefile.am index f71ea77671..658f03bd54 100644 --- a/Makefile.am +++ b/Makefile.am @@ -307,7 +307,10 @@ STORE_MODULES = \ MODULES += $(STORE_MODULES) # Internal modules with test suite support. -dist_noinst_DATA = guix/tests.scm guix/tests/http.scm +dist_noinst_DATA = \ + guix/tests.scm \ + guix/tests/http.scm \ + guix/tests/git.scm # Auxiliary files for packages. AUX_FILES = \ @@ -391,6 +394,7 @@ SCM_TESTS = \ tests/file-systems.scm \ tests/gem.scm \ tests/gexp.scm \ + tests/git.scm \ tests/glob.scm \ tests/gnu-maintenance.scm \ tests/grafts.scm \ diff --git a/guix/git.scm b/guix/git.scm index 92a7353b5a..d7dddde3a7 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -28,6 +28,7 @@ (define-module (guix git) #:use-module (guix utils) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix sets) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -37,8 +38,10 @@ (define-module (guix git) #:export (%repository-cache-directory honor-system-x509-certificates! + with-repository update-cached-checkout latest-repository-commit + commit-difference git-checkout git-checkout? @@ -339,6 +342,43 @@ (define (print-git-error port key args default-printer) (set-exception-printer! 'git-error print-git-error) + +;;; +;;; Commit difference. +;;; + +(define (commit-closure commit) + "Return the closure of COMMIT as a set." + (let loop ((commits (list commit)) + (visited (setq))) + (match commits + (() + visited) + ((head . tail) + (if (set-contains? visited head) + (loop tail visited) + (loop (append (commit-parents head) tail) + (set-insert head visited))))))) + +(define (commit-difference new old) + "Return the list of commits between NEW and OLD, where OLD is assumed to be +an ancestor of NEW. + +Essentially, this computes the set difference between the closure of NEW and +that of OLD." + (let loop ((commits (list new)) + (result '()) + (visited (commit-closure old))) + (match commits + (() + (reverse result)) + ((head . tail) + (if (set-contains? visited head) + (loop tail result visited) + (loop (append (commit-parents head) tail) + (cons head result) + (set-insert head visited))))))) + ;;; ;;; Checkouts. diff --git a/guix/tests/git.scm b/guix/tests/git.scm new file mode 100644 index 0000000000..52abe77c83 --- /dev/null +++ b/guix/tests/git.scm @@ -0,0 +1,97 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; 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 tests git) + #:use-module (git) + #:use-module (guix utils) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 control) + #:export (git-command + with-temporary-git-repository + find-commit)) + +(define git-command + (make-parameter "git")) + +(define (populate-git-repository directory directives) + "Initialize a new Git checkout and repository in DIRECTORY and apply +DIRECTIVES. Each element of DIRECTIVES is an sexp like: + + (add \"foo.txt\" \"hi!\") + +Return DIRECTORY on success." + + ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do + ;; all this, so resort to the "git" command. + (define (git command . args) + (apply invoke (git-command) "-C" directory + command args)) + + (mkdir-p directory) + (git "init") + + (let loop ((directives directives)) + (match directives + (() + directory) + ((('add file contents) rest ...) + (let ((file (string-append directory "/" file))) + (mkdir-p (dirname file)) + (call-with-output-file file + (lambda (port) + (display contents port))) + (git "add" file) + (loop rest))) + ((('commit text) rest ...) + (git "commit" "-m" text) + (loop rest)) + ((('branch name) rest ...) + (git "branch" name) + (loop rest)) + ((('checkout branch) rest ...) + (git "checkout" branch) + (loop rest)) + ((('merge branch message) rest ...) + (git "merge" branch "-m" message) + (loop rest))))) + +(define (call-with-temporary-git-repository directives proc) + (call-with-temporary-directory + (lambda (directory) + (populate-git-repository directory directives) + (proc directory)))) + +(define-syntax-rule (with-temporary-git-repository directory + directives exp ...) + "Evaluate EXP in a context where DIRECTORY contains a checkout populated as +per DIRECTIVES." + (call-with-temporary-git-repository directives + (lambda (directory) + exp ...))) + +(define (find-commit repository message) + "Return the commit in REPOSITORY whose message includes MESSAGE, a string." + (let/ec return + (fold-commits (lambda (commit _) + (and (string-contains (commit-message commit) + message) + (return commit))) + #f + repository) + (error "commit not found" message))) diff --git a/tests/git.scm b/tests/git.scm new file mode 100644 index 0000000000..8ba10ece51 --- /dev/null +++ b/tests/git.scm @@ -0,0 +1,99 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; 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 (test-git) + #:use-module (git) + #:use-module (guix git) + #:use-module (guix tests git) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +;; Test the (guix git) tools. + +(test-begin "git") + +;; 'with-temporary-git-repository' relies on the 'git' command. +(unless (which (git-command)) (test-skip 1)) +(test-assert "commit-difference, linear history" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "first commit") + (add "b.txt" "B") + (commit "second commit") + (add "c.txt" "C") + (commit "third commit") + (add "d.txt" "D") + (commit "fourth commit")) + (with-repository directory repository + (let ((commit1 (find-commit repository "first")) + (commit2 (find-commit repository "second")) + (commit3 (find-commit repository "third")) + (commit4 (find-commit repository "fourth"))) + (and (lset= eq? (commit-difference commit4 commit1) + (list commit2 commit3 commit4)) + (lset= eq? (commit-difference commit4 commit2) + (list commit3 commit4)) + (equal? (commit-difference commit3 commit2) + (list commit3)) + + ;; COMMIT4 is not an ancestor of COMMIT1 so we should get the + ;; empty list. + (null? (commit-difference commit1 commit4))))))) + +(unless (which (git-command)) (test-skip 1)) +(test-assert "commit-difference, fork" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "first commit") + (branch "devel") + (checkout "devel") + (add "devel/1.txt" "1") + (commit "first devel commit") + (add "devel/2.txt" "2") + (commit "second devel commit") + (checkout "master") + (add "b.txt" "B") + (commit "second commit") + (add "c.txt" "C") + (commit "third commit") + (merge "devel" "merge") + (add "d.txt" "D") + (commit "fourth commit")) + (with-repository directory repository + (let ((master1 (find-commit repository "first commit")) + (master2 (find-commit repository "second commit")) + (master3 (find-commit repository "third commit")) + (master4 (find-commit repository "fourth commit")) + (devel1 (find-commit repository "first devel")) + (devel2 (find-commit repository "second devel")) + (merge (find-commit repository "merge"))) + (and (equal? (commit-difference master4 merge) + (list master4)) + (lset= eq? (commit-difference master3 master1) + (list master3 master2)) + (lset= eq? (commit-difference devel2 master1) + (list devel2 devel1)) + + ;; The merge occurred between MASTER2 and MASTER4 so here we + ;; expect to see all the commits from the "devel" branch in + ;; addition to those on "master". + (lset= eq? (commit-difference master4 master2) + (list master4 merge master3 devel1 devel2))))))) + +(test-end "git") -- cgit v1.2.3 From 8ba7fd3cd6962f1c1aaaa5f71eed7f9222094f25 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 14 Sep 2019 23:16:54 +0200 Subject: channels: Add support for a news file. * guix/channels.scm ()[news-file]: New field. (read-channel-metadata): Set the 'news-file' field. (read-channel-metadata-from-source): Likewise. (, ): New record types. (sexp->channel-news-entry, read-channel-news) (channel-news-for-commit): New procedures. * guix/tests/git.scm (populate-git-repository): For 'add', allow CONTENTS to be a procedure. * tests/channels.scm ("channel-news, no news") ("channel-news, one entry"): New tests. * doc/guix.texi (Channels): Document it. --- doc/guix.texi | 62 +++++++++++++++++++++++++++ guix/channels.scm | 123 +++++++++++++++++++++++++++++++++++++++++++++++++---- guix/tests/git.scm | 7 ++- tests/channels.scm | 99 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 282 insertions(+), 9 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index af1903f6ff..cd108faa8f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3991,6 +3991,68 @@ add a meta-data file @file{.guix-channel} that contains: (directory "guix")) @end lisp +@cindex news, for channels +@subsection Writing Channel News + +Channel authors may occasionally want to communicate to their users +information about important changes in the channel. You'd send them all +an email, but that's not convenient. + +Instead, channels can provide a @dfn{news file}; when the channel users +run @command{guix pull}, that news file is automatically read and +@command{guix pull --news} can display the announcements that correspond +to the new commits that have been pulled, if any. + +To do that, channel authors must first declare the name of the news file +in their @file{.guix-channel} file: + +@lisp +(channel + (version 0) + (news-file "etc/news.txt")) +@end lisp + +The news file itself, @file{etc/news.txt} in this example, must look +something like this: + +@lisp +(channel-news + (version 0) + (entry (commit "d894ab8e9bfabcefa6c49d9ba2e834dd5a73a300") + (title (en "Fixed terrible bug") + (fr "Oh la la")) + (body (en "@@emph@{Good news@}! It's fixed!") + (eo "Certe ĝi pli bone funkcias nun!"))) + (entry (commit "bdcabe815cd28144a2d2b4bc3c5057b051fa9906") + (title (en "Added a great package") + (ca "Què vol dir guix?")) + (body (en "Don't miss the @@code@{hello@} package!")))) +@end lisp + +The file consists of a list of @dfn{news entries}. Each entry is +associated with a commit: it describes changes made in this commit, +possibly in preceding commits as well. Users see entries only the first +time they obtain the commit the entry refers to. + +The @code{title} field should be a one-line summary while @code{body} +can be arbitrarily long, and both can contain Texinfo markup +(@pxref{Overview,,, texinfo, GNU Texinfo}). Both the title and body are +a list of language tag/message tuples, which allows @command{guix pull} +to display news in the language that corresponds to the user's locale. + +If you want to translate news using a gettext-based workflow, you can +extract translatable strings with @command{xgettext} (@pxref{xgettext +Invocation,,, gettext, GNU Gettext Utilities}). For example, assuming +you write news entries in English first, the command below creates a PO +file containing the strings to translate: + +@example +xgettext -o news.po -l scheme -ken etc/news.scm +@end example + +To sum up, yes, you could use your channel as a blog. But beware, this +is @emph{not quite} what your users might expect. + @subsection Replicating Guix @cindex pinning, channels diff --git a/guix/channels.scm b/guix/channels.scm index ebb2cacbc7..0dadba616f 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -19,6 +19,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix channels) + #:use-module (git) #:use-module (guix git) #:use-module (guix records) #:use-module (guix gexp) @@ -29,6 +30,7 @@ (define-module (guix channels) #:use-module (guix derivations) #:use-module (guix combinators) #:use-module (guix diagnostics) + #:use-module (guix sets) #:use-module (guix store) #:use-module (guix i18n) #:use-module ((guix utils) @@ -67,7 +69,14 @@ (define-module (guix channels) %channel-profile-hooks channel-instances->derivation - profile-channels)) + profile-channels + + channel-news-entry? + channel-news-entry-commit + channel-news-entry-title + channel-news-entry-body + + channel-news-for-commit)) ;;; Commentary: ;;; @@ -110,10 +119,11 @@ (define-record-type (checkout channel-instance-checkout)) (define-record-type - (channel-metadata directory dependencies) + (channel-metadata directory dependencies news-file) channel-metadata? (directory channel-metadata-directory) ;string with leading slash - (dependencies channel-metadata-dependencies)) ;list of + (dependencies channel-metadata-dependencies) ;list of + (news-file channel-metadata-news-file)) ;string | #f (define (channel-reference channel) "Return the \"reference\" for CHANNEL, an sexp suitable for @@ -129,12 +139,13 @@ (define (read-channel-metadata port) (match (read port) (('channel ('version 0) properties ...) (let ((directory (and=> (assoc-ref properties 'directory) first)) - (dependencies (or (assoc-ref properties 'dependencies) '()))) + (dependencies (or (assoc-ref properties 'dependencies) '())) + (news-file (and=> (assoc-ref properties 'news-file) first))) (channel-metadata - (cond ((not directory) "/") + (cond ((not directory) "/") ;directory ((string-prefix? "/" directory) directory) (else (string-append "/" directory))) - (map (lambda (item) + (map (lambda (item) ;dependencies (let ((get (lambda* (key #:optional default) (or (and=> (assoc-ref item key) first) default)))) (and-let* ((name (get 'name)) @@ -145,7 +156,8 @@ (define (read-channel-metadata port) (branch branch) (url url) (commit (get 'commit)))))) - dependencies)))) + dependencies) + news-file))) ;news-file ((and ('channel ('version version) _ ...) sexp) (raise (condition (&message (message "unsupported '.guix-channel' version")) @@ -169,7 +181,7 @@ (define (read-channel-metadata-from-source source) read-channel-metadata)) (lambda args (if (= ENOENT (system-error-errno args)) - (channel-metadata "/" '()) + (channel-metadata "/" '() #f) (apply throw args))))) (define (channel-instance-metadata instance) @@ -560,3 +572,98 @@ (define (profile-channels profile) ;; Show most recently installed packages last. (reverse (manifest-entries (profile-manifest profile))))) + + +;;; +;;; News. +;;; + +;; Channel news. +(define-record-type + (channel-news entries) + channel-news? + (entries channel-news-entries)) ;list of + +;; News entry, associated with a specific commit of the channel. +(define-record-type + (channel-news-entry commit title body) + channel-news-entry? + (commit channel-news-entry-commit) ;hex string + (title channel-news-entry-title) ;list of language tag/string pairs + (body channel-news-entry-body)) ;list of language tag/string pairs + +(define (sexp->channel-news-entry entry) + "Return the record corresponding to ENTRY, an sexp." + (define (pair language message) + (cons (symbol->string language) message)) + + (match entry + (('entry ('commit commit) + ('title ((? symbol? title-tags) (? string? titles)) ...) + ('body ((? symbol? body-tags) (? string? bodies)) ...) + _ ...) + (channel-news-entry commit + (map pair title-tags titles) + (map pair body-tags bodies))) + (_ + (raise (condition + (&message (message "invalid channel news entry")) + (&error-location + (location (source-properties->location + (source-properties entry))))))))) + +(define (read-channel-news port) + "Read a channel news feed from PORT and return it as a +record." + (match (false-if-exception (read port)) + (('channel-news ('version 0) entries ...) + (channel-news (map sexp->channel-news-entry entries))) + (('channel-news ('version version) _ ...) + ;; This is an unsupported version from the future. There's nothing wrong + ;; with that (the user may simply need to upgrade the 'guix' channel to + ;; be able to read it), so silently ignore it. + (channel-news '())) + (#f + (raise (condition + (&message (message "syntactically invalid channel news file"))))) + (sexp + (raise (condition + (&message (message "invalid channel news file")) + (&error-location + (location (source-properties->location + (source-properties sexp))))))))) + +(define* (channel-news-for-commit channel new #:optional old) + "Return a list of for CHANNEL between commits OLD and +NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." + (catch 'git-error + (lambda () + (let* ((checkout (update-cached-checkout (channel-url channel) + #:ref `(commit . ,new))) + (metadata (read-channel-metadata-from-source checkout)) + (news-file (channel-metadata-news-file metadata)) + (news-file (and news-file + (string-append checkout "/" news-file)))) + (if (and news-file (file-exists? news-file)) + (let ((entries (channel-news-entries (call-with-input-file news-file + read-channel-news)))) + (if old + (with-repository checkout repository + (let* ((new (commit-lookup repository (string->oid new))) + (old (commit-lookup repository (string->oid old))) + (commits (list->set + (map (compose oid->string commit-id) + (commit-difference new old))))) + (filter (lambda (entry) + (set-contains? commits + (channel-news-entry-commit entry))) + entries))) + entries)) + '()))) + (lambda (key error . rest) + ;; If commit NEW or commit OLD cannot be found, then something must be + ;; wrong (for example, the history of CHANNEL was rewritten and these + ;; commits no longer exist upstream), so quietly return the empty list. + (if (= GIT_ENOTFOUND (git-error-code error)) + '() + (apply throw key error rest))))) diff --git a/guix/tests/git.scm b/guix/tests/git.scm index 52abe77c83..9d5b1ae321 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -18,6 +18,7 @@ (define-module (guix tests git) #:use-module (git) + #:use-module ((guix git) #:select (with-repository)) #:use-module (guix utils) #:use-module (guix build utils) #:use-module (ice-9 match) @@ -55,7 +56,11 @@ (define (git command . args) (mkdir-p (dirname file)) (call-with-output-file file (lambda (port) - (display contents port))) + (display (if (string? contents) + contents + (with-repository directory repository + (contents repository))) + port))) (git "add" file) (loop rest))) ((('commit text) rest ...) diff --git a/tests/channels.scm b/tests/channels.scm index e83b5437d3..58101bcb72 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -28,6 +28,10 @@ (define-module (test-channels) #:use-module (guix gexp) #:use-module ((guix utils) #:select (error-location? error-location location-line)) + #:use-module ((guix build utils) #:select (which)) + #:use-module (git) + #:use-module (guix git) + #:use-module (guix tests git) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -246,4 +250,99 @@ (define (lookup name) (depends? drv3 (list drv2 drv0) (list)))))))) +(unless (which (git-command)) (test-skip 1)) +(test-equal "channel-news, no news" + '() + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "the commit")) + (with-repository directory repository + (let ((channel (channel (url (string-append "file://" directory)) + (name 'foo))) + (latest (reference-name->oid repository "HEAD"))) + (channel-news-for-commit channel (oid->string latest)))))) + +(unless (which (git-command)) (test-skip 1)) +(test-assert "channel-news, one entry" + (with-temporary-git-repository directory + `((add ".guix-channel" + ,(object->string + '(channel (version 0) + (news-file "news.scm")))) + (commit "first commit") + (add "src/a.txt" "A") + (commit "second commit") + (add "news.scm" + ,(lambda (repository) + (let ((previous + (reference-name->oid repository "HEAD"))) + (object->string + `(channel-news + (version 0) + (entry (commit ,(oid->string previous)) + (title (en "New file!") + (eo "Nova dosiero!")) + (body (en "Yeah, a.txt.")))))))) + (commit "third commit") + (add "src/b.txt" "B") + (commit "fourth commit") + (add "news.scm" + ,(lambda (repository) + (let ((second + (commit-id + (find-commit repository "second commit"))) + (previous + (reference-name->oid repository "HEAD"))) + (object->string + `(channel-news + (version 0) + (entry (commit ,(oid->string previous)) + (title (en "Another file!")) + (body (en "Yeah, b.txt."))) + (entry (commit ,(oid->string second)) + (title (en "Old news.") + (eo "Malnovaĵoj.")) + (body (en "For a.txt")))))))) + (commit "fifth 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")) + (commit3 (find-commit* "third commit")) + (commit4 (find-commit* "fourth commit")) + (commit5 (find-commit* "fifth commit"))) + ;; First try fetching all the news up to a given commit. + (and (null? (channel-news-for-commit channel commit2)) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit5)) + (list commit2 commit4)) + (lset= equal? + (map channel-news-entry-title + (channel-news-for-commit channel commit5)) + '((("en" . "Another file!")) + (("en" . "Old news.") ("eo" . "Malnovaĵoj.")))) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit3)) + (list commit2)) + + ;; Now fetch news entries that apply to a commit range. + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit3 commit1)) + (list commit2)) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit5 commit3)) + (list commit4)) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit5 commit1)) + (list commit4 commit2))))))) + (test-end "channels") -- cgit v1.2.3 From 9719e8d37aaa63e1c8f9d4ab1e28d49e2e56d85b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Sep 2019 21:29:30 +0200 Subject: channels: Allow news entries to refer to a tag. Suggested by Ricardo Wurmus . * guix/channels.scm ()[tag]: New field. (sexp->channel-news-entry): Accept either 'commit' or 'tag' in 'entry' forms. (resolve-channel-news-entry-tag): New procedure. (channel-news-for-commit): Move 'with-repository' form one level higher. Call 'resolve-channel-news-entry-tag' on all the news entries. * guix/tests/git.scm (populate-git-repository): Add clause for 'tag'. * tests/channels.scm ("channel-news, one entry"): Create a tag and add an entry with a tag. Check that the tag is resolved and also visible in the record. * doc/guix.texi (Channels): Mention tags in news entries. --- doc/guix.texi | 8 ++++---- guix/channels.scm | 42 ++++++++++++++++++++++++++++++++---------- guix/tests/git.scm | 3 +++ tests/channels.scm | 9 +++++++-- 4 files changed, 46 insertions(+), 16 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index cd108faa8f..33bf08e9dd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4018,7 +4018,7 @@ something like this: @lisp (channel-news (version 0) - (entry (commit "d894ab8e9bfabcefa6c49d9ba2e834dd5a73a300") + (entry (tag "the-bug-fix") (title (en "Fixed terrible bug") (fr "Oh la la")) (body (en "@@emph@{Good news@}! It's fixed!") @@ -4030,9 +4030,9 @@ something like this: @end lisp The file consists of a list of @dfn{news entries}. Each entry is -associated with a commit: it describes changes made in this commit, -possibly in preceding commits as well. Users see entries only the first -time they obtain the commit the entry refers to. +associated with a commit or tag: it describes changes made in this +commit, possibly in preceding commits as well. Users see entries only +the first time they obtain the commit the entry refers to. The @code{title} field should be a one-line summary while @code{body} can be arbitrarily long, and both can contain Texinfo markup diff --git a/guix/channels.scm b/guix/channels.scm index 0dadba616f..4e6e7090ac 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -40,6 +40,7 @@ (define-module (guix channels) #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:autoload (guix self) (whole-package make-config.scm) @@ -73,6 +74,7 @@ (define-module (guix channels) channel-news-entry? channel-news-entry-commit + channel-news-entry-tag channel-news-entry-title channel-news-entry-body @@ -586,9 +588,10 @@ (define-record-type ;; News entry, associated with a specific commit of the channel. (define-record-type - (channel-news-entry commit title body) + (channel-news-entry commit tag title body) channel-news-entry? - (commit channel-news-entry-commit) ;hex string + (commit channel-news-entry-commit) ;hex string | #f + (tag channel-news-entry-tag) ;#f | string (title channel-news-entry-title) ;list of language tag/string pairs (body channel-news-entry-body)) ;list of language tag/string pairs @@ -598,11 +601,12 @@ (define (pair language message) (cons (symbol->string language) message)) (match entry - (('entry ('commit commit) + (('entry ((and (or 'commit 'tag) type) commit-or-tag) ('title ((? symbol? title-tags) (? string? titles)) ...) ('body ((? symbol? body-tags) (? string? bodies)) ...) _ ...) - (channel-news-entry commit + (channel-news-entry (and (eq? type 'commit) commit-or-tag) + (and (eq? type 'tag) commit-or-tag) (map pair title-tags titles) (map pair body-tags bodies))) (_ @@ -633,6 +637,20 @@ (define (read-channel-news port) (location (source-properties->location (source-properties sexp))))))))) +(define (resolve-channel-news-entry-tag repository entry) + "If ENTRY has its 'commit' field set, return ENTRY. Otherwise, lookup +ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to +the field its 'tag' refers to. A 'git-error' exception is raised if the tag +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))) + (channel-news-entry (oid->string oid) tag + (channel-news-entry-title entry) + (channel-news-entry-body entry))))) + (define* (channel-news-for-commit channel new #:optional old) "Return a list of for CHANNEL between commits OLD and NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." @@ -645,10 +663,14 @@ (define* (channel-news-for-commit channel new #:optional old) (news-file (and news-file (string-append checkout "/" news-file)))) (if (and news-file (file-exists? news-file)) - (let ((entries (channel-news-entries (call-with-input-file news-file - read-channel-news)))) - (if old - (with-repository checkout repository + (with-repository checkout repository + (let* ((news (call-with-input-file news-file + read-channel-news)) + (entries (map (lambda (entry) + (resolve-channel-news-entry-tag repository + entry)) + (channel-news-entries news)))) + (if old (let* ((new (commit-lookup repository (string->oid new))) (old (commit-lookup repository (string->oid old))) (commits (list->set @@ -657,8 +679,8 @@ (define* (channel-news-for-commit channel new #:optional old) (filter (lambda (entry) (set-contains? commits (channel-news-entry-commit entry))) - entries))) - entries)) + entries)) + entries))) '()))) (lambda (key error . rest) ;; If commit NEW or commit OLD cannot be found, then something must be diff --git a/guix/tests/git.scm b/guix/tests/git.scm index 9d5b1ae321..21573ac14e 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -66,6 +66,9 @@ (define (git command . args) ((('commit text) rest ...) (git "commit" "-m" text) (loop rest)) + ((('tag name) rest ...) + (git "tag" name) + (loop rest)) ((('branch name) rest ...) (git "branch" name) (loop rest)) diff --git a/tests/channels.scm b/tests/channels.scm index 58101bcb72..f5a7955483 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -272,6 +272,7 @@ (define (lookup name) (commit "first commit") (add "src/a.txt" "A") (commit "second commit") + (tag "tag-for-first-news-entry") (add "news.scm" ,(lambda (repository) (let ((previous @@ -299,7 +300,7 @@ (define (lookup name) (entry (commit ,(oid->string previous)) (title (en "Another file!")) (body (en "Yeah, b.txt."))) - (entry (commit ,(oid->string second)) + (entry (tag "tag-for-first-news-entry") (title (en "Old news.") (eo "Malnovaĵoj.")) (body (en "For a.txt")))))))) @@ -343,6 +344,10 @@ (define (find-commit* message) (lset= string=? (map channel-news-entry-commit (channel-news-for-commit channel commit5 commit1)) - (list commit4 commit2))))))) + (list commit4 commit2)) + (lset= equal? + (map channel-news-entry-tag + (channel-news-for-commit channel commit5 commit1)) + '(#f "tag-for-first-news-entry"))))))) (test-end "channels") -- cgit v1.2.3 From 24ab804ce11fe12ff49cd144a3d9c4bfcf55b41c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Sep 2019 22:17:39 +0200 Subject: gexp: Catch and report non-self-quoting gexp inputs. Previously we would, for example, generate build scripts in the store; when trying to run them, we'd get a 'read' error due to the presence of # syntax in there. * guix/gexp.scm (gexp->sexp)[self-quoting?]: New procedure. [reference->sexp]: Check whether the argument in a box is self-quoting. Raise a '&gexp-input-error' condition if it's not. * tests/gexp.scm ("lower-gexp, non-self-quoting input"): New test. --- guix/gexp.scm | 13 ++++++++++++- tests/gexp.scm | 7 +++++++ 2 files changed, 19 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/gexp.scm b/guix/gexp.scm index 45cd5869f7..0d0b661c65 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1005,6 +1005,15 @@ (define* (gexp->sexp exp #:key (target (%current-target-system))) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, and in the current monad setting (system type, etc.)" + (define (self-quoting? x) + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? keyword? pair? null? array? + number? boolean?))) + (define* (reference->sexp ref #:optional native?) (with-monad %store-monad (match ref @@ -1034,8 +1043,10 @@ (define* (reference->sexp ref #:optional native?) #:target target))) ;; OBJ must be either a derivation or a store file name. (return (expand thing obj output))))) - (($ x) + (($ (? self-quoting? x)) (return x)) + (($ x) + (raise (condition (&gexp-input-error (input x))))) (x (return x))))) diff --git a/tests/gexp.scm b/tests/gexp.scm index 5c013d838d..50d0948659 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -871,6 +871,13 @@ (define (matching-input drv output) (eq? (derivation-input-derivation (lowered-gexp-guile lexp)) (%guile-for-build))))))) +(test-eq "lower-gexp, non-self-quoting input" + + + (guard (c ((gexp-input-error? c) + (gexp-error-invalid-input c))) + (run-with-store %store + (lower-gexp #~(foo #$+))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) -- cgit v1.2.3