From 79601521fceb6b2f76d87cf3df45a76e43b1ffcf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Aug 2014 21:52:32 +0200 Subject: profiles: Compute transaction effects in a functional way. * guix/profiles.scm (manifest-transaction-effects): New procedure. (manifest-show-transaction): Use it instead of locally computing it. * tests/profiles.scm (glibc): New variable. ("manifest-transaction-effects"): New test. --- tests/profiles.scm | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'tests') diff --git a/tests/profiles.scm b/tests/profiles.scm index 047c5ba49b..d88def32fd 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -26,6 +26,7 @@ #:use-module (guix derivations) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-64)) ;; Test the (guix profiles) module. @@ -53,6 +54,13 @@ (manifest-entry (inherit guile-2.0.9) (output "debug"))) +(define glibc + (manifest-entry + (name "glibc") + (version "2.19") + (item "/gnu/store/...") + (output "out"))) + (test-begin "profiles") @@ -136,6 +144,17 @@ (equal? m1 m2) (null? (manifest-entries m3))))) +(test-assert "manifest-transaction-effects" + (let* ((m0 (manifest (list guile-1.8.8))) + (t (manifest-transaction + (install (list guile-2.0.9 glibc)) + (remove (list (manifest-pattern (name "coreutils"))))))) + (let-values (((remove install upgrade) + (manifest-transaction-effects m0 t))) + (and (null? remove) + (equal? (list glibc) install) + (equal? (list guile-2.0.9) upgrade))))) + (test-assert "profile-derivation" (run-with-store %store (mlet* %store-monad -- cgit v1.2.3 From 44d43c7a854effb2bc42eb9c0aea3594415fad6a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 31 Aug 2014 14:43:38 +0200 Subject: daemon: Really enable automatic deduplication by default. * nix/nix-daemon/guix-daemon.cc (main): Set 'autoStoreOptimise' to true. Add 'printMsg' call. * tests/derivations.scm ("identical files are deduplicated"): New test. --- nix/nix-daemon/guix-daemon.cc | 7 +++++++ tests/derivations.scm | 22 ++++++++++++++++++++++ 2 files changed, 29 insertions(+) (limited to 'tests') diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc index 0bb9f7559c..0309743de1 100644 --- a/nix/nix-daemon/guix-daemon.cc +++ b/nix/nix-daemon/guix-daemon.cc @@ -249,6 +249,9 @@ main (int argc, char *argv[]) settings.useChroot = false; #endif + /* Turn automatic deduplication on by default. */ + settings.autoOptimiseStore = true; + argvSaved = argv; try @@ -325,6 +328,10 @@ main (int argc, char *argv[]) } #endif + printMsg (lvlDebug, + format ("automatic deduplication set to %1%") + % settings.autoOptimiseStore); + printMsg (lvlDebug, format ("listening on `%1%'") % settings.nixDaemonSocketFile); diff --git a/tests/derivations.scm b/tests/derivations.scm index 19bcebcb21..855b059d16 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -151,6 +151,28 @@ ;; the contents. (valid-path? %store (derivation->output-path drv))))) +(test-assert "identical files are deduplicated" + (let* ((build1 (add-text-to-store %store "one.sh" + "echo hello, world > \"$out\"\n" + '())) + (build2 (add-text-to-store %store "two.sh" + "# Hey!\necho hello, world > \"$out\"\n" + '())) + (drv1 (derivation %store "foo" + %bash `(,build1) + #:inputs `((,%bash) (,build1)))) + (drv2 (derivation %store "bar" + %bash `(,build2) + #:inputs `((,%bash) (,build2))))) + (and (build-derivations %store (list drv1 drv2)) + (let ((file1 (derivation->output-path drv1)) + (file2 (derivation->output-path drv2))) + (and (valid-path? %store file1) (valid-path? %store file2) + (string=? (call-with-input-file file1 get-string-all) + "hello, world\n") + (= (stat:ino (lstat file1)) + (stat:ino (lstat file2)))))))) + (test-assert "fixed-output-derivation?" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" "echo -n hello > $out" '())) -- cgit v1.2.3 From ef8993e2dc90fd5d63d016fc45912ad451bf787c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Sep 2014 21:12:59 +0200 Subject: profiles: Report the old and new version number in upgrades. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/profiles.scm (manifest-lookup): New procedure. (manifest-installed?): Use it. (manifest-transaction-effects): Return a pair of entries for upgrades. (right-arrow): New procedure. (manifest-show-transaction)[upgrade-string, →]: New variables. Report upgrades using 'upgrade-string'. * tests/profiles.scm ("manifest-show-transaction"): New test. ("manifest-transaction-effects"): Match UPGRADE against a pair. --- guix/profiles.scm | 53 +++++++++++++++++++++++++++++++++++++++++++++-------- tests/profiles.scm | 20 +++++++++++++++++++- 2 files changed, 64 insertions(+), 9 deletions(-) (limited to 'tests') diff --git a/guix/profiles.scm b/guix/profiles.scm index 843040156c..52bd5bc332 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -53,6 +53,7 @@ manifest-remove manifest-add + manifest-lookup manifest-installed? manifest-matching-entries @@ -237,11 +238,16 @@ Remove MANIFEST entries that have the same name and output as ENTRIES." (manifest-entries manifest) entries)))) +(define (manifest-lookup manifest pattern) + "Return the first item of MANIFEST that matches PATTERN, or #f if there is +no match.." + (find (entry-predicate pattern) + (manifest-entries manifest))) + (define (manifest-installed? manifest pattern) "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern), #f otherwise." - (->bool (find (entry-predicate pattern) - (manifest-entries manifest)))) + (->bool (manifest-lookup manifest pattern))) (define (manifest-matching-entries manifest patterns) "Return all the entries of MANIFEST that match one of the PATTERNS." @@ -271,7 +277,9 @@ Remove MANIFEST entries that have the same name and output as ENTRIES." (define (manifest-transaction-effects manifest transaction) "Compute the effect of applying TRANSACTION to MANIFEST. Return 3 values: the list of packages that would be removed, installed, or upgraded when -applying TRANSACTION to MANIFEST." +applying TRANSACTION to MANIFEST. Upgrades are represented as pairs where the +head is the entry being upgraded and the tail is the entry that will replace +it." (define (manifest-entry->pattern entry) (manifest-pattern (name (manifest-entry-name entry)) @@ -292,10 +300,12 @@ applying TRANSACTION to MANIFEST." ;; XXX: When the exact same output directory is installed, we're not ;; really upgrading anything. Add a check for that case. (let* ((pattern (manifest-entry->pattern entry)) - (upgrade? (manifest-installed? manifest pattern))) + (previous (manifest-lookup manifest pattern))) (loop rest - (if upgrade? install (cons entry install)) - (if upgrade? (cons entry upgrade) upgrade))))))) + (if previous install (cons entry install)) + (if previous + (alist-cons previous entry upgrade) + upgrade))))))) (define (manifest-perform-transaction manifest transaction) "Perform TRANSACTION on MANIFEST and return new manifest." @@ -304,6 +314,20 @@ applying TRANSACTION to MANIFEST." (manifest-add (manifest-remove manifest remove) install))) +(define (right-arrow port) + "Return either a string containing the 'RIGHT ARROW' character, or an ASCII +replacement if PORT is not Unicode-capable." + (with-fluids ((%default-port-encoding (port-encoding port))) + (let ((arrow "→")) + (catch 'encoding-error + (lambda () + (with-fluids ((%default-port-conversion-strategy 'error)) + (with-output-to-string + (lambda () + (display arrow))))) + (lambda (key . args) + ">"))))) + (define* (manifest-show-transaction store manifest transaction #:key dry-run?) "Display what will/would be installed/removed from MANIFEST by TRANSACTION." @@ -315,6 +339,17 @@ applying TRANSACTION to MANIFEST." item))) name version output item)) + (define → ;an arrow that can be represented on stderr + (right-arrow (current-error-port))) + + (define (upgrade-string name old-version new-version output item) + (format #f " ~a\t~a ~a ~a\t~a\t~a" name + old-version → new-version + output + (if (package? item) + (package-output store item output) + item))) + (let-values (((remove install upgrade) (manifest-transaction-effects manifest transaction))) (match remove @@ -334,9 +369,11 @@ applying TRANSACTION to MANIFEST." remove)))) (_ #f)) (match upgrade - ((($ name version output item _) ..1) + (((($ name old-version) + . ($ _ new-version output item)) ..1) (let ((len (length name)) - (upgrade (package-strings name version output item))) + (upgrade (map upgrade-string + name old-version new-version output item))) (if dry-run? (format (current-error-port) (N_ "The following package would be upgraded:~%~{~a~%~}~%" diff --git a/tests/profiles.scm b/tests/profiles.scm index d88def32fd..879f71073f 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -26,6 +26,7 @@ #:use-module (guix derivations) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64)) @@ -153,7 +154,24 @@ (manifest-transaction-effects m0 t))) (and (null? remove) (equal? (list glibc) install) - (equal? (list guile-2.0.9) upgrade))))) + (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade))))) + +(test-assert "manifest-show-transaction" + (let* ((m (manifest (list guile-1.8.8))) + (t (manifest-transaction (install (list guile-2.0.9))))) + (let-values (((remove install upgrade) + (manifest-transaction-effects m t))) + (with-store store + (and (string-match "guile\t1.8.8 → 2.0.9" + (with-fluids ((%default-port-encoding "UTF-8")) + (with-error-to-string + (lambda () + (manifest-show-transaction store m t))))) + (string-match "guile\t1.8.8 > 2.0.9" + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (with-error-to-string + (lambda () + (manifest-show-transaction store m t)))))))))) (test-assert "profile-derivation" (run-with-store %store -- cgit v1.2.3 From b4f5e0e87c112bd4b8425be0c17524ce9c2a85ca Mon Sep 17 00:00:00 2001 From: Cyril Roelandt Date: Mon, 1 Sep 2014 02:13:21 +0200 Subject: scripts: add guix lint * guix/scripts/lint.scm: New file. Defines a 'lint' tool for Guix packages. * tests/lint.scm: New file. * Makefile.am (MODULES, SCM_TESTS): Add them. * po/guix/Makevars: Update appropriately. * po/guix/POTFILES.in: Update appropriately. * doc/guix.texi: Document "guix lint". --- Makefile.am | 4 +- doc/guix.texi | 29 ++++++- guix/scripts/lint.scm | 213 ++++++++++++++++++++++++++++++++++++++++++++++++++ po/guix/Makevars | 3 +- po/guix/POTFILES.in | 1 + tests/lint.scm | 110 ++++++++++++++++++++++++++ 6 files changed, 357 insertions(+), 3 deletions(-) create mode 100644 guix/scripts/lint.scm create mode 100644 tests/lint.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index fff5958355..371b85c235 100644 --- a/Makefile.am +++ b/Makefile.am @@ -89,6 +89,7 @@ MODULES = \ guix/scripts/authenticate.scm \ guix/scripts/refresh.scm \ guix/scripts/system.scm \ + guix/scripts/lint.scm \ guix.scm \ $(GNU_SYSTEM_MODULES) @@ -159,7 +160,8 @@ SCM_TESTS = \ tests/nar.scm \ tests/union.scm \ tests/profiles.scm \ - tests/syscalls.scm + tests/syscalls.scm \ + tests/lint.scm SH_TESTS = \ tests/guix-build.sh \ diff --git a/doc/guix.texi b/doc/guix.texi index 46f2c70b85..384e2a9ced 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1459,7 +1459,10 @@ definitions like the one above may be automatically converted from the Nixpkgs distribution using the @command{guix import} command.}, the package may actually be built using the @code{guix build} command-line tool (@pxref{Invoking guix build}). @xref{Packaging Guidelines}, for -more information on how to test package definitions. +more information on how to test package definitions, and +@ref{Invoking guix lint}, for information on how to check a definition +for style conformance. + Eventually, updating the package definition to a new upstream version can be partly automated by the @command{guix refresh} command @@ -2328,6 +2331,7 @@ programming interface of Guix in a convenient way. * Invoking guix download:: Downloading a file and printing its hash. * Invoking guix hash:: Computing the cryptographic hash of a file. * Invoking guix refresh:: Updating package definitions. +* Invoking guix lint:: Finding errors in package definitions. @end menu @node Invoking guix build @@ -2705,6 +2709,29 @@ for in @code{$PATH}. @end table +@node Invoking guix lint +@section Invoking @command{guix lint} +The @command{guix lint} is meant to help package developers avoid common +errors and use a consistent style. It runs a few checks on a given set of +packages in order to find common mistakes in their definitions. + +The general syntax is: + +@example +guix lint @var{options} @var{package}@dots{} +@end example + +If no package is given on the command line, then all packages are checked. +The @var{options} may be zero or more of the following: + +@table @code + +@item --list-checkers +@itemx -l +List and describe all the available checkers that will be run on packages +and exit. + +@end table @c ********************************************************************* @node GNU Distribution diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm new file mode 100644 index 0000000000..e3b06977ee --- /dev/null +++ b/guix/scripts/lint.scm @@ -0,0 +1,213 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Cyril Roelandt +;;; +;;; 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 lint) + #:use-module (guix base32) + #:use-module (guix packages) + #:use-module (guix records) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (gnu packages) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:export (guix-lint + check-inputs-should-be-native + check-patches + check-synopsis-style)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + '()) + +(define (show-help) + (display (_ "Usage: guix lint [OPTION]... [PACKAGE]... +Run a set of checkers on the specified package; if none is specified, run the checkers on all packages.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -l, --list-checkers display the list of available lint checkers")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + ;; TODO: add some options: + ;; * --checkers=checker1,checker2...: only run the specified checkers + ;; * --certainty=[low,medium,high]: only run checkers that have at least this + ;; 'certainty'. + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\l "list-checkers") #f #f + (lambda args + (list-checkers-and-exit))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix lint"))))) + + +;;; +;;; Helpers +;;; +(define* (emit-warning package message #:optional field) + ;; Emit a warning about PACKAGE, printing the location of FIELD if it is + ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the + ;; provided MESSAGE. + (let ((loc (or (package-field-location package field) + (package-location package)))) + (warning (_ "~a: ~a: ~a~%") + (location->string loc) + (package-full-name package) + message))) + + +;;; +;;; Checkers +;;; +(define-record-type* + lint-checker make-lint-checker + lint-checker? + ;; TODO: add a 'certainty' field that shows how confident we are in the + ;; checker. Then allow users to only run checkers that have a certain + ;; 'certainty' level. + (name lint-checker-name) + (description lint-checker-description) + (check lint-checker-check)) + +(define (list-checkers-and-exit) + ;; Print information about all available checkers and exit. + (format #t (_ "Available checkers:~%")) + (for-each (lambda (checker) + (format #t "- ~a: ~a~%" + (lint-checker-name checker) + (lint-checker-description checker))) + %checkers) + (exit 0)) + +(define (check-inputs-should-be-native package) + ;; Emit a warning if some inputs of PACKAGE are likely to belong to its + ;; native inputs. + (let ((inputs (package-inputs package))) + (match inputs + (((labels packages . _) ...) + (when (member "pkg-config" + (map package-name (filter package? packages))) + (emit-warning package + "pkg-config should probably be a native input" + 'inputs)))))) + + +(define (check-synopsis-style package) + ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE. + (define (check-final-period synopsis) + ;; Synopsis should not end with a period, except for some special cases. + (if (and (string=? (string-take-right synopsis 1) ".") + (not (string=? (string-take-right synopsis 4) "etc."))) + (emit-warning package + "no period allowed at the end of the synopsis" + 'synopsis))) + + (define (check-start-article synopsis) + (if (or (string=? (string-take synopsis 2) "A ") + (string=? (string-take synopsis 3) "An ")) + (emit-warning package + "no article allowed at the beginning of the synopsis" + 'synopsis))) + + (let ((synopsis (package-synopsis package))) + (if (string? synopsis) + (begin + (check-final-period synopsis) + (check-start-article synopsis))))) + +(define (check-patches package) + ;; Emit a warning if the patches requires by PACKAGE are badly named. + (let ((patches (and=> (package-source package) origin-patches)) + (name (package-name package)) + (full-name (package-full-name package))) + (if (and patches + (any (lambda (patch) + (let ((filename (basename patch))) + (not (or (eq? (string-contains filename name) 0) + (eq? (string-contains filename full-name) 0))))) + patches)) + (emit-warning package + "file names of patches should start with the package name" + 'patches)))) + +(define %checkers + (list + (lint-checker + (name "inputs-should-be-native") + (description "Identify inputs that should be native inputs") + (check check-inputs-should-be-native)) + (lint-checker + (name "patch-filenames") + (description "Validate filenames of patches") + (check check-patches)) + (lint-checker + (name "synopsis") + (description "Validate package synopsis") + (check check-synopsis-style)))) + +(define (run-checkers package) + ;; Run all the checkers on PACKAGE. + (for-each (lambda (checker) + ((lint-checker-check checker) package)) + %checkers)) + + +;;; +;;; Entry Point +;;; + +(define (guix-lint . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + + + (if (null? args) + (fold-packages (lambda (p r) (run-checkers p)) '()) + (for-each + (lambda (spec) + (run-checkers spec)) + (map specification->package args))))) diff --git a/po/guix/Makevars b/po/guix/Makevars index 87bb438418..f5b498caa9 100644 --- a/po/guix/Makevars +++ b/po/guix/Makevars @@ -10,7 +10,8 @@ top_builddir = ../.. XGETTEXT_OPTIONS = \ --language=Scheme --from-code=UTF-8 \ --keyword=_ --keyword=N_ \ - --keyword=message + --keyword=message \ + --keyword=description COPYRIGHT_HOLDER = Ludovic Courtès diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index bf2d31306a..5cc68ff404 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -10,6 +10,7 @@ guix/scripts/pull.scm guix/scripts/substitute-binary.scm guix/scripts/authenticate.scm guix/scripts/system.scm +guix/scripts/lint.scm guix/gnu-maintenance.scm guix/ui.scm guix/http-client.scm diff --git a/tests/lint.scm b/tests/lint.scm new file mode 100644 index 0000000000..f6dae47ca6 --- /dev/null +++ b/tests/lint.scm @@ -0,0 +1,110 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Cyril Roelandt +;;; +;;; 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-packages) + #:use-module (guix build download) + #:use-module (guix build-system gnu) + #:use-module (guix packages) + #:use-module (guix scripts lint) + #:use-module (guix ui) + #:use-module (gnu packages) + #:use-module (gnu packages pkg-config) + #:use-module (srfi srfi-64)) + +;; Test the linter. + + +(test-begin "lint") + +(define-syntax-rule (dummy-package name* extra-fields ...) + (package extra-fields ... (name name*) (version "0") (source #f) + (build-system gnu-build-system) + (synopsis #f) (description #f) + (home-page #f) (license #f) )) + +(define (call-with-warnings thunk) + (let ((port (open-output-string))) + (parameterize ((guix-warning-port port)) + (thunk)) + (get-output-string port))) + +(test-assert "synopsis: ends with a period" + (->bool + (string-contains (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (synopsis "Bad synopsis.")))) + (check-synopsis-style pkg)))) + "no period allowed at the end of the synopsis"))) + +(test-assert "synopsis: ends with 'etc.'" + (->bool + (string-null? (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (synopsis "Foo, bar, etc.")))) + (check-synopsis-style pkg))))))) + +(test-assert "synopsis: starts with 'A'" + (->bool + (string-contains (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (synopsis "A bad synopŝis")))) + (check-synopsis-style pkg)))) + "no article allowed at the beginning of the synopsis"))) + +(test-assert "synopsis: starts with 'An'" + (->bool + (string-contains (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (synopsis "An awful synopsis")))) + (check-synopsis-style pkg)))) + "no article allowed at the beginning of the synopsis"))) + +(test-assert "inputs: pkg-config is probably a native input" + (->bool + (string-contains + (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (inputs `(("pkg-config" ,pkg-config)))))) + (check-inputs-should-be-native pkg)))) + "pkg-config should probably be a native input"))) + +(test-assert "patches: file names" + (->bool + (string-contains + (call-with-warnings + (lambda () + (let ((pkg (dummy-package "x" + (source + (origin + (method url-fetch) + (uri "someurl") + (sha256 "somesha") + (patches (list "/path/to/y.patch"))))))) + (check-patches pkg)))) + "file names of patches should start with the package name"))) + +(test-end "lint") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From b002e9d08eb909e9fa1a84b0feed1662dce0bd3f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 Sep 2014 09:01:28 +0200 Subject: guix lint: Remove "guix lint: " prefix from warnings. This allows editors to parse warnings correctly. * guix/scripts/lint.scm (emit-warning): Use 'format' instead of 'warning', to avoid the "guix lint: " prefix in messages. * tests/lint.scm (call-with-warnings): Indent. --- guix/scripts/lint.scm | 8 ++++---- tests/lint.scm | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) (limited to 'tests') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index e3b06977ee..83dde9a1a1 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -81,10 +81,10 @@ Run a set of checkers on the specified package; if none is specified, run the ch ;; provided MESSAGE. (let ((loc (or (package-field-location package field) (package-location package)))) - (warning (_ "~a: ~a: ~a~%") - (location->string loc) - (package-full-name package) - message))) + (format (guix-warning-port) (_ "~a: ~a: ~a~%") + (location->string loc) + (package-full-name package) + message))) ;;; diff --git a/tests/lint.scm b/tests/lint.scm index f6dae47ca6..56558c904f 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -39,10 +39,10 @@ (home-page #f) (license #f) )) (define (call-with-warnings thunk) - (let ((port (open-output-string))) - (parameterize ((guix-warning-port port)) - (thunk)) - (get-output-string port))) + (let ((port (open-output-string))) + (parameterize ((guix-warning-port port)) + (thunk)) + (get-output-string port))) (test-assert "synopsis: ends with a period" (->bool -- cgit v1.2.3 From 39c4563aeaa525e71328d1ec08ef568c8a124152 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Sep 2014 21:35:57 +0200 Subject: profiles: Use a real arrow to denote upgrades in ASCII. Suggested by Alex Kost. * guix/profiles.scm (right-arrow): Fall back to "->". * tests/profiles.scm ("manifest-show-transaction"): Adjust accordingly. --- guix/profiles.scm | 2 +- tests/profiles.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/guix/profiles.scm b/guix/profiles.scm index 919f27d250..9dc9ab43b9 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -326,7 +326,7 @@ replacement if PORT is not Unicode-capable." (lambda () (display arrow))))) (lambda (key . args) - ">"))))) + "->"))))) (define* (manifest-show-transaction store manifest transaction #:key dry-run?) diff --git a/tests/profiles.scm b/tests/profiles.scm index 879f71073f..99f1fd2763 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -167,7 +167,7 @@ (with-error-to-string (lambda () (manifest-show-transaction store m t))))) - (string-match "guile\t1.8.8 > 2.0.9" + (string-match "guile\t1.8.8 -> 2.0.9" (with-fluids ((%default-port-encoding "ISO-8859-1")) (with-error-to-string (lambda () -- cgit v1.2.3 From 6fd1a7967481037560d2ab25f31da182822ef889 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Sep 2014 23:05:12 +0200 Subject: vm: Move store copy handling to (guix build store-copy). * gnu/build/vm.scm (read-reference-graph, populate-store): Move to... * guix/build/store-copy.scm: ... here. New file. * Makefile.am (MODULES): Add it. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Adjust default #:modules values accordingly. * tests/gexp.scm ("gexp->derivation, store copy"): New test. --- Makefile.am | 1 + gnu/build/vm.scm | 37 +------------------------ gnu/system/vm.scm | 3 ++- guix/build/store-copy.scm | 69 +++++++++++++++++++++++++++++++++++++++++++++++ tests/gexp.scm | 38 ++++++++++++++++++++++++++ 5 files changed, 111 insertions(+), 37 deletions(-) create mode 100644 guix/build/store-copy.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 156c560665..1f2c4db80d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -64,6 +64,7 @@ MODULES = \ guix/build/gnu-dist.scm \ guix/build/perl-build-system.scm \ guix/build/python-build-system.scm \ + guix/build/store-copy.scm \ guix/build/utils.scm \ guix/build/union.scm \ guix/build/pull.scm \ diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index ad63a2240d..27ccd047b7 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -18,12 +18,11 @@ (define-module (gnu build vm) #:use-module (guix build utils) + #:use-module (guix build store-copy) #:use-module (gnu build linux-boot) #:use-module (gnu build install) #:use-module (ice-9 match) #:use-module (ice-9 regex) - #:use-module (ice-9 rdelim) - #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (qemu-command load-in-linux-vm @@ -111,20 +110,6 @@ the #:references-graphs parameter of 'derivation'." (mkdir output) (copy-recursively "xchg" output)))) -(define (read-reference-graph port) - "Return a list of store paths from the reference graph at PORT. -The data at PORT is the format produced by #:references-graphs." - (let loop ((line (read-line port)) - (result '())) - (cond ((eof-object? line) - (delete-duplicates result)) - ((string-prefix? "/" line) - (loop (read-line port) - (cons line result))) - (else - (loop (read-line port) - result))))) - (define* (initialize-partition-table device partition-size #:key (label-type "msdos") @@ -140,26 +125,6 @@ success." (format #f "~aB" partition-size))) (error "failed to create partition table"))) -(define* (populate-store reference-graphs target) - "Populate the store under directory TARGET with the items specified in -REFERENCE-GRAPHS, a list of reference-graph files." - (define store - (string-append target (%store-directory))) - - (define (things-to-copy) - ;; Return the list of store files to copy to the image. - (define (graph-from-file file) - (call-with-input-file file read-reference-graph)) - - (delete-duplicates (append-map graph-from-file reference-graphs))) - - (mkdir-p store) - (chmod store #o1775) - (for-each (lambda (thing) - (copy-recursively thing - (string-append target thing))) - (things-to-copy))) - (define MS_BIND 4096) ; again! (define* (format-partition partition type diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index d263edb4f1..624f2a680a 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -116,7 +116,8 @@ input tuple. The output file name is when building for SYSTEM." (gnu build install) (gnu build linux-boot) (gnu build file-systems) - (guix build utils))) + (guix build utils) + (guix build store-copy))) (guile-for-build (%guile-for-build)) diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm new file mode 100644 index 0000000000..a296bdf78f --- /dev/null +++ b/guix/build/store-copy.scm @@ -0,0 +1,69 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014 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 build store-copy) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (ice-9 rdelim) + #:export (read-reference-graph + populate-store)) + +;;; Commentary: +;;; +;;; This module provides the tools to copy store items and their dependencies +;;; to another store. It relies on the availability of "reference graph" +;;; files as produced by 'gexp->derivation' et al. with the +;;; #:references-graphs parameter. +;;; +;;; Code: + +(define (read-reference-graph port) + "Return a list of store paths from the reference graph at PORT. +The data at PORT is the format produced by #:references-graphs." + (let loop ((line (read-line port)) + (result '())) + (cond ((eof-object? line) + (delete-duplicates result)) + ((string-prefix? "/" line) + (loop (read-line port) + (cons line result))) + (else + (loop (read-line port) + result))))) + +(define* (populate-store reference-graphs target) + "Populate the store under directory TARGET with the items specified in +REFERENCE-GRAPHS, a list of reference-graph files." + (define store + (string-append target (%store-directory))) + + (define (things-to-copy) + ;; Return the list of store files to copy to the image. + (define (graph-from-file file) + (call-with-input-file file read-reference-graph)) + + (delete-duplicates (append-map graph-from-file reference-graphs))) + + (mkdir-p store) + (chmod store #o1775) + (for-each (lambda (thing) + (copy-recursively thing + (string-append target thing))) + (things-to-copy))) + +;;; store-copy.scm ends here diff --git a/tests/gexp.scm b/tests/gexp.scm index bf52401c66..a08164c484 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -324,6 +324,44 @@ (return (string=? (derivation-file-name drv) (derivation-file-name xdrv))))) +(test-assertm "gexp->derivation, store copy" + (let ((build-one #~(call-with-output-file #$output + (lambda (port) + (display "This is the one." port)))) + (build-two (lambda (one) + #~(begin + (mkdir #$output) + (symlink #$one (string-append #$output "/one")) + (call-with-output-file (string-append #$output "/two") + (lambda (port) + (display "This is the second one." port)))))) + (build-drv (lambda (two) + #~(begin + (use-modules (guix build store-copy)) + + (mkdir #$output) + '#$two ;make it an input + (populate-store '("graph") #$output))))) + (mlet* %store-monad ((one (gexp->derivation "one" build-one)) + (two (gexp->derivation "two" (build-two one))) + (dir -> (derivation->output-path two)) + (drv (gexp->derivation "store-copy" (build-drv two) + #:references-graphs + `(("graph" . ,dir)) + #:modules + '((guix build store-copy) + (guix build utils)))) + (ok? (built-derivations (list drv))) + (out -> (derivation->output-path drv))) + (let ((one (derivation->output-path one)) + (two (derivation->output-path two))) + (return (and ok? + (file-exists? (string-append out "/" one)) + (file-exists? (string-append out "/" two)) + (file-exists? (string-append out "/" two "/two")) + (string=? (readlink (string-append out "/" two "/one")) + one))))))) + (define shebang (string-append "#!" (derivation->output-path (%guile-for-build)) "/bin/guile --no-auto-compile")) -- cgit v1.2.3 From b53833b2ef36cf139f65193bec688396a734b0d0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 6 Sep 2014 15:45:32 +0200 Subject: gexp: Allow use of high-level objects in #:references-graphs. * guix/gexp.scm (lower-reference-graphs): New procedure. (gexp->derivation)[graphs-file-names]: New procedure. Use 'lower-reference-graphs', and augment #:inputs argument as a function of #:references-graphs. * doc/guix.texi (G-Expressions): Adjust 'gexp->derivation' documentation accordingly. * tests/gexp.scm ("gexp->derivation, store copy"): Remove reference to TWO in BUILD-DRV. Use TWO directly in #:references-graphs argument. ("gexp->derivation #:references-graphs"): New test. * gnu/system/vm.scm (qemu-image): Remove variable 'graph'; use INPUTS as the #:references-graphs argument to 'expression->derivation-in-linux-vm'. --- doc/guix.texi | 16 +++++++++++ gnu/system/vm.scm | 82 +++++++++++++++++++++++++++---------------------------- guix/gexp.scm | 51 ++++++++++++++++++++++++++++++++-- tests/gexp.scm | 52 +++++++++++++++++++++++++++++------ 4 files changed, 148 insertions(+), 53 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 1f192bf0a7..e0251f5ffd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2278,6 +2278,22 @@ search path to be copied in the store, compiled, and made available in the load path during the execution of @var{exp}---e.g., @code{((guix build utils) (guix build gnu-build-system))}. +When @var{references-graphs} is true, it must be a list of tuples of one of the +following forms: + +@example +(@var{file-name} @var{package}) +(@var{file-name} @var{package} @var{output}) +(@var{file-name} @var{derivation}) +(@var{file-name} @var{derivation} @var{output}) +(@var{file-name} @var{store-item}) +@end example + +The right-hand-side of each element of @var{references-graphs} is automatically made +an input of the build process of @var{exp}. In the build environment, each +@var{file-name} contains the reference graph of the corresponding item, in a simple +text format. + The other arguments are as for @code{derivation} (@pxref{Derivations}). @end deffn diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 624f2a680a..205bf2cb19 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -219,48 +219,46 @@ INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in the image." - (mlet %store-monad - ((graph (sequence %store-monad (map input->name+output inputs)))) - (expression->derivation-in-linux-vm - name - #~(begin - (use-modules (gnu build vm) - (guix build utils)) - - (let ((inputs - '#$(append (list qemu parted grub e2fsprogs util-linux) - (map canonical-package - (list sed grep coreutils findutils gawk)) - (if register-closures? (list guix) '()))) - - ;; This variable is unused but allows us to add INPUTS-TO-COPY - ;; as inputs. - (to-register - '#$(map (match-lambda - ((name thing) thing) - ((name thing output) `(,thing ,output))) - inputs))) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - - (let ((graphs '#$(match inputs - (((names . _) ...) - names)))) - (initialize-hard-disk "/dev/vda" - #:system-directory #$os-derivation - #:grub.cfg #$grub-configuration - #:closures graphs - #:copy-closures? #$copy-inputs? - #:register-closures? #$register-closures? - #:disk-image-size #$disk-image-size - #:file-system-type #$file-system-type - #:file-system-label #$file-system-label) - (reboot)))) - #:system system - #:make-disk-image? #t - #:disk-image-size disk-image-size - #:disk-image-format disk-image-format - #:references-graphs graph))) + (expression->derivation-in-linux-vm + name + #~(begin + (use-modules (gnu build vm) + (guix build utils)) + + (let ((inputs + '#$(append (list qemu parted grub e2fsprogs util-linux) + (map canonical-package + (list sed grep coreutils findutils gawk)) + (if register-closures? (list guix) '()))) + + ;; This variable is unused but allows us to add INPUTS-TO-COPY + ;; as inputs. + (to-register + '#$(map (match-lambda + ((name thing) thing) + ((name thing output) `(,thing ,output))) + inputs))) + + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + + (let ((graphs '#$(match inputs + (((names . _) ...) + names)))) + (initialize-hard-disk "/dev/vda" + #:system-directory #$os-derivation + #:grub.cfg #$grub-configuration + #:closures graphs + #:copy-closures? #$copy-inputs? + #:register-closures? #$register-closures? + #:disk-image-size #$disk-image-size + #:file-system-type #$file-system-type + #:file-system-label #$file-system-label) + (reboot)))) + #:system system + #:make-disk-image? #t + #:disk-image-size disk-image-size + #:disk-image-format disk-image-format + #:references-graphs inputs)) ;;; diff --git a/guix/gexp.scm b/guix/gexp.scm index e31324e101..5401cbf96f 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -109,6 +109,17 @@ the cross-compilation target triplet." (return input))) inputs)))) +(define* (lower-reference-graphs graphs #:key system target) + "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a +#:reference-graphs argument, lower it such that each INPUT is replaced by the +corresponding derivation." + (match graphs + (((file-names . inputs) ...) + (mlet %store-monad ((inputs (lower-inputs inputs + #:system system + #:target target))) + (return (map cons file-names inputs)))))) + (define* (gexp->derivation name exp #:key system (target 'current) @@ -127,10 +138,38 @@ names of Guile modules from the current search path to be copied in the store, compiled, and made available in the load path during the execution of EXP---e.g., '((guix build utils) (guix build gnu-build-system)). +When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the +following forms: + + (FILE-NAME PACKAGE) + (FILE-NAME PACKAGE OUTPUT) + (FILE-NAME DERIVATION) + (FILE-NAME DERIVATION OUTPUT) + (FILE-NAME STORE-ITEM) + +The right-hand-side of each element of REFERENCES-GRAPHS is automatically made +an input of the build process of EXP. In the build environment, each +FILE-NAME contains the reference graph of the corresponding item, in a simple +text format. + +In that case, the reference graph of each store path is exported in +the build environment in the corresponding file, in a simple text format. + The other arguments are as for 'derivation'." (define %modules modules) (define outputs (gexp-outputs exp)) + (define (graphs-file-names graphs) + ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. + (map (match-lambda + ((file-name (? derivation? drv)) + (cons file-name (derivation->output-path drv))) + ((file-name (? derivation? drv) sub-drv) + (cons file-name (derivation->output-path drv sub-drv))) + ((file-name thing) + (cons file-name thing))) + graphs)) + (mlet* %store-monad (;; The following binding is here to force ;; '%current-system' and '%current-target-system' to be ;; looked up at >>= time. @@ -162,6 +201,11 @@ The other arguments are as for 'derivation'." #:system system #:guile guile-for-build) (return #f))) + (graphs (if references-graphs + (lower-reference-graphs references-graphs + #:system system + #:target target) + (return #f))) (guile (if guile-for-build (return guile-for-build) (package->derivation (default-guile) @@ -182,9 +226,12 @@ The other arguments are as for 'derivation'." (,builder) ,@(if modules `((,modules) (,compiled) ,@inputs) - inputs)) + inputs) + ,@(match graphs + (((_ . inputs) ...) inputs) + (_ '()))) #:hash hash #:hash-algo hash-algo #:recursive? recursive? - #:references-graphs references-graphs + #:references-graphs (and=> graphs graphs-file-names) #:local-build? local-build?))) (define* (gexp-inputs exp #:optional (references gexp-references)) diff --git a/tests/gexp.scm b/tests/gexp.scm index a08164c484..ea4df48403 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -335,19 +335,16 @@ (call-with-output-file (string-append #$output "/two") (lambda (port) (display "This is the second one." port)))))) - (build-drv (lambda (two) - #~(begin - (use-modules (guix build store-copy)) + (build-drv #~(begin + (use-modules (guix build store-copy)) - (mkdir #$output) - '#$two ;make it an input - (populate-store '("graph") #$output))))) + (mkdir #$output) + (populate-store '("graph") #$output)))) (mlet* %store-monad ((one (gexp->derivation "one" build-one)) (two (gexp->derivation "two" (build-two one))) - (dir -> (derivation->output-path two)) - (drv (gexp->derivation "store-copy" (build-drv two) + (drv (gexp->derivation "store-copy" build-drv #:references-graphs - `(("graph" . ,dir)) + `(("graph" ,two)) #:modules '((guix build store-copy) (guix build utils)))) @@ -362,6 +359,43 @@ (string=? (readlink (string-append out "/" two "/one")) one))))))) +(test-assertm "gexp->derivation #:references-graphs" + (mlet* %store-monad + ((one (text-file "one" "hello, world")) + (two (gexp->derivation "two" + #~(symlink #$one #$output:chbouib))) + (drv (gexp->derivation "ref-graphs" + #~(begin + (use-modules (guix build store-copy)) + (with-output-to-file #$output + (lambda () + (write (call-with-input-file "guile" + read-reference-graph)))) + (with-output-to-file #$output:one + (lambda () + (write (call-with-input-file "one" + read-reference-graph)))) + (with-output-to-file #$output:two + (lambda () + (write (call-with-input-file "two" + read-reference-graph))))) + #:references-graphs `(("one" ,one) + ("two" ,two "chbouib") + ("guile" ,%bootstrap-guile)) + #:modules '((guix build store-copy) + (guix build utils)))) + (ok? (built-derivations (list drv))) + (guile-drv (package->derivation %bootstrap-guile)) + (g-one -> (derivation->output-path drv "one")) + (g-two -> (derivation->output-path drv "two")) + (g-guile -> (derivation->output-path drv))) + (return (and ok? + (equal? (call-with-input-file g-one read) (list one)) + (equal? (call-with-input-file g-two read) + (list one (derivation->output-path two "chbouib"))) + (equal? (call-with-input-file g-guile read) + (list (derivation->output-path guile-drv))))))) + (define shebang (string-append "#!" (derivation->output-path (%guile-for-build)) "/bin/guile --no-auto-compile")) -- cgit v1.2.3