From 0e510971c3f6e5203803f14c40b89fe37d3d3f53 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 19 Jan 2016 21:38:44 +0100 Subject: derivations: Add test in keep-going mode. * tests/derivations.scm ("derivation fails but keep going"): New test. --- tests/derivations.scm | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) (limited to 'tests') diff --git a/tests/derivations.scm b/tests/derivations.scm index 64cc8a94c9..db96e26ab1 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -151,6 +151,33 @@ ;; the contents. (valid-path? %store (derivation->output-path drv))))) +(test-assert "derivation fails but keep going" + ;; In keep-going mode, 'build-derivations' should fail because of D1, but it + ;; must return only after D2 has succeeded. + (with-store store + (let* ((d1 (derivation %store "fails" + %bash `("-c" "false") + #:inputs `((,%bash)))) + (d2 (build-expression->derivation %store "sleep-then-succeed" + `(begin + ,(random-text) + ;; XXX: Hopefully that's long + ;; enough that D1 has already + ;; failed. + (sleep 2) + (mkdir %output))))) + (set-build-options %store + #:use-substitutes? #f + #:keep-going? #t) + (guard (c ((nix-protocol-error? c) + (and (= 100 (nix-protocol-error-status c)) + (string-contains (nix-protocol-error-message c) + (derivation-file-name d1)) + (not (valid-path? %store (derivation->output-path d1))) + (valid-path? %store (derivation->output-path d2))))) + (build-derivations %store (list d1 d2)) + #f)))) + (test-assert "identical files are deduplicated" (let* ((build1 (add-text-to-store %store "one.sh" "echo hello, world > \"$out\"\n" -- cgit v1.2.3 From d0bd632f89e242a2a217d7e85194589f088f75ea Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 16 Dec 2015 14:45:28 +0100 Subject: import: Add Bioconductor importer and updater. * guix/import/cran.scm (%bioconductor-updater, latest-bioconductor-release, bioconductor-package?): New procedures. (cran->guix-package): Support repositories other than CRAN. (%bioconductor-url, %bioconductor-svn-url): New variables. (description->package): Update signature to distinguish between packages from different repositories. (latest-release): Rename procedure ... (latest-cran-release): ... to this. (cran-package?): Do not assume all R packages are available on CRAN. * tests/cran.scm: Update tests. * guix/scripts/import/cran.scm: Add "--archive" option and default to CRAN. * guix/scripts/refresh.scm (%updaters): Add "%bioconductor-updater". * doc/guix.texi: Document Bioconductor importer and updater. --- doc/guix.texi | 20 ++++++++- guix/import/cran.scm | 103 ++++++++++++++++++++++++++++++++++--------- guix/scripts/import/cran.scm | 9 +++- guix/scripts/refresh.scm | 1 + tests/cran.scm | 2 +- 5 files changed, 112 insertions(+), 23 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index a3d751a296..2a97516084 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4279,11 +4279,12 @@ guix import cpan Acme::Boolean @item cran @cindex CRAN +@cindex Bioconductor Import meta-data from @uref{http://cran.r-project.org/, CRAN}, the central repository for the @uref{http://r-project.org, GNU@tie{}R statistical and graphical environment}. -Information is extracted from the package's DESCRIPTION file. +Information is extracted from the package's @code{DESCRIPTION} file. The command command below imports meta-data for the @code{Cairo} R package: @@ -4292,6 +4293,21 @@ R package: guix import cran Cairo @end example +When @code{--archive=bioconductor} is added, meta-data is imported from +@uref{http://www.bioconductor.org/, Bioconductor}, a repository of R +packages for for the analysis and comprehension of high-throughput +genomic data in bioinformatics. + +Information is extracted from a package's @code{DESCRIPTION} file +published on the web interface of the Bioconductor SVN repository. + +The command command below imports meta-data for the @code{GenomicRanges} +R package: + +@example +guix import cran --archive=bioconductor GenomicRanges +@end example + @item nix Import meta-data from a local copy of the source of the @uref{http://nixos.org/nixpkgs/, Nixpkgs distribution}@footnote{This @@ -4490,6 +4506,8 @@ the updater for GNOME packages; the updater for @uref{http://elpa.gnu.org/, ELPA} packages; @item cran the updater for @uref{http://cran.r-project.org/, CRAN} packages; +@item bioconductor +the updater for @uref{http://www.bioconductor.org/, Bioconductor} R packages; @item pypi the updater for @uref{https://pypi.python.org, PyPI} packages. @end table diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 1c30da89c7..f36e9482cf 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -29,12 +29,14 @@ #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) - #:use-module ((guix build-system r) #:select (cran-uri)) + #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) #:use-module (guix upstream) #:use-module (guix packages) #:use-module (gnu packages) #:export (cran->guix-package - %cran-updater)) + bioconductor->guix-package + %cran-updater + %bioconductor-updater)) ;;; Commentary: ;;; @@ -108,6 +110,15 @@ package definition." `((,type (,'quasiquote ,(format-inputs package-inputs))))))) (define %cran-url "http://cran.r-project.org/web/packages/") +(define %bioconductor-url "http://bioconductor.org/packages/") + +;; The latest Bioconductor release is 3.2. Bioconductor packages should be +;; updated together. +(define %bioconductor-svn-url + (string-append "https://readonly:readonly@" + "hedgehog.fhcrc.org/bioconductor/branches/RELEASE_3_2/" + "madman/Rpacks/")) + (define (fetch-description base-url name) "Return an alist of the contents of the DESCRIPTION file for the R package @@ -136,24 +147,31 @@ empty list when the FIELD cannot be found." (string-any char-set:whitespace item))) (map string-trim-both items)))))) -(define (description->package meta) - "Return the `package' s-expression for a CRAN package from the alist META, -which was derived from the R package's DESCRIPTION file." +(define (description->package repository meta) + "Return the `package' s-expression for an R package published on REPOSITORY +from the alist META, which was derived from the R package's DESCRIPTION file." (define (guix-name name) (if (string-prefix? "r-" name) (string-downcase name) (string-append "r-" (string-downcase name)))) - (let* ((name (assoc-ref meta "Package")) + (let* ((base-url (case repository + ((cran) %cran-url) + ((bioconductor) %bioconductor-url))) + (uri-helper (case repository + ((cran) cran-uri) + ((bioconductor) bioconductor-uri))) + (name (assoc-ref meta "Package")) (synopsis (assoc-ref meta "Title")) (version (assoc-ref meta "Version")) (license (string->license (assoc-ref meta "License"))) ;; Some packages have multiple home pages. Some have none. (home-page (match (listify meta "URL") ((url rest ...) url) - (_ (string-append %cran-url name)))) - (source-url (match (cran-uri name version) + (_ (string-append base-url name)))) + (source-url (match (uri-helper name version) ((url rest ...) url) + ((? string? url) url) (_ #f))) (tarball (with-store store (download-to-store store source-url))) (sysdepends (map string-downcase (listify meta "SystemRequirements"))) @@ -167,26 +185,32 @@ which was derived from the R package's DESCRIPTION file." (version ,version) (source (origin (method url-fetch) - (uri (cran-uri ,name version)) + (uri (,(procedure-name uri-helper) ,name version)) (sha256 (base32 ,(bytevector->nix-base32-string (file-sha256 tarball)))))) - (properties ,`(,'quasiquote ((,'upstream-name . ,name)))) + ,@(if (not (equal? (string-append "r-" name) + (guix-name name))) + `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) + '()) (build-system r-build-system) ,@(maybe-inputs sysdepends) ,@(maybe-inputs propagate 'propagated-inputs) (home-page ,(if (string-null? home-page) - (string-append %cran-url name) + (string-append base-url name) home-page)) (synopsis ,synopsis) (description ,(beautify-description (assoc-ref meta "Description"))) (license ,license)))) -(define (cran->guix-package package-name) - "Fetch the metadata for PACKAGE-NAME from cran.r-project.org, and return the -`package' s-expression corresponding to that package, or #f on failure." - (let ((module-meta (fetch-description %cran-url package-name))) - (and=> module-meta description->package))) +(define* (cran->guix-package package-name #:optional (repo 'cran)) + "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' +s-expression corresponding to that package, or #f on failure." + (let* ((url (case repo + ((cran) %cran-url) + ((bioconductor) %bioconductor-svn-url))) + (module-meta (fetch-description url package-name))) + (and=> module-meta (cut description->package repo <>)))) ;;; @@ -212,7 +236,7 @@ which was derived from the R package's DESCRIPTION file." (_ #f))) (_ #f))))) -(define (latest-release package) +(define (latest-cran-release package) "Return an for the latest release of PACKAGE." (define upstream-name @@ -229,16 +253,55 @@ which was derived from the R package's DESCRIPTION file." (version version) (urls (cran-uri upstream-name version)))))) +(define (latest-bioconductor-release package) + "Return an for the latest release of PACKAGE." + + (define upstream-name + (package->upstream-name (specification->package package))) + + (define meta + (fetch-description %bioconductor-svn-url upstream-name)) + + (and meta + (let ((version (assoc-ref meta "Version"))) + ;; Bioconductor does not provide signatures. + (upstream-source + (package package) + (version version) + (urls (bioconductor-uri upstream-name version)))))) + (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." - ;; Assume all R packages are available on CRAN. - (string-prefix? "r-" (package-name package))) + (and (string-prefix? "r-" (package-name package)) + (match (and=> (package-source package) origin-uri) + ((? string? uri) + (string-prefix? "mirror://cran" uri)) + ((? list? uris) + (any (cut string-prefix? "mirror://cran" <>) uris)) + (_ #f)))) + +(define (bioconductor-package? package) + "Return true if PACKAGE is an R package from Bioconductor." + (and (string-prefix? "r-" (package-name package)) + (match (and=> (package-source package) origin-uri) + ((? string? uri) + (string-prefix? "http://bioconductor.org" uri)) + ((? list? uris) + (any (cut string-prefix? "http://bioconductor.org" <>) uris)) + (_ #f)))) (define %cran-updater (upstream-updater (name 'cran) (description "Updater for CRAN packages") (pred cran-package?) - (latest latest-release))) + (latest latest-cran-release))) + +(define %bioconductor-updater + (upstream-updater + (name 'bioconductor) + (description "Updater for Bioconductor packages") + (pred bioconductor-package?) + (latest latest-bioconductor-release))) ;;; cran.scm ends here diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 8d001ac494..ace1123b90 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -41,6 +41,8 @@ (define (show-help) (display (_ "Usage: guix import cran PACKAGE-NAME Import and convert the CRAN package for PACKAGE-NAME.\n")) + (display (_ " + -a, --archive=ARCHIVE specify the archive repository")) (display (_ " -h, --help display this help and exit")) (display (_ " @@ -57,6 +59,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import cran"))) + (option '(#\a "archive") #t #f + (lambda (opt name arg result) + (alist-cons 'repo (string->symbol arg) + (alist-delete 'repo result)))) %standard-import-options)) @@ -82,7 +88,8 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (cran->guix-package package-name))) + (let ((sexp (cran->guix-package package-name + (or (assoc-ref opts 'repo) 'cran)))) (unless sexp (leave (_ "failed to download description for package '~a'~%") package-name)) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index a5834d12cc..f9e3f31a03 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -195,6 +195,7 @@ unavailable optional dependencies such as Guile-JSON." %gnome-updater %elpa-updater %cran-updater + %bioconductor-updater ((guix import pypi) => %pypi-updater))) (define (lookup-updater name) diff --git a/tests/cran.scm b/tests/cran.scm index 0a4a2fdd8f..e4f22353bd 100644 --- a/tests/cran.scm +++ b/tests/cran.scm @@ -107,7 +107,7 @@ Date/Publication: 2015-07-14 14:15:16 ("mirror://cran/src/contrib/My-Example_1.2.3.tar.gz" "source") (_ (error "Unexpected URL: " url)))))))) - (match ((@@ (guix import cran) description->package) description-alist) + (match ((@@ (guix import cran) description->package) 'cran description-alist) (('package ('name "r-my-example") ('version "1.2.3") -- cgit v1.2.3 From e88d5fa9ebab07d0b23cb3fc0f3f38bd41047e94 Mon Sep 17 00:00:00 2001 From: Ben Woodcroft Date: Sun, 17 Jan 2016 09:12:14 +1000 Subject: import: gem: Beautify only the description, not the synopsis. * guix/import/gem.scm (make-gem-sexp): Add synopsis argument. (gem->guix-package): Pass unbeautified synopsis to make-gem-sexp. * tests/gem.scm: Adapt it. --- guix/import/gem.scm | 7 ++++--- tests/gem.scm | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 3c42052f1a..4b2a253130 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -77,7 +77,7 @@ the package." (bytevector-u8-set! bv i (read-byte i)) (loop (1+ i))))))) -(define (make-gem-sexp name version hash home-page description +(define (make-gem-sexp name version hash home-page synopsis description dependencies licenses) "Return the `package' s-expression for a Ruby package with the given NAME, VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." @@ -101,7 +101,7 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." (,'unquote ,(string->symbol name)))) dependencies))))) - (synopsis ,description) ; nothing better to use + (synopsis ,synopsis) (description ,description) (home-page ,home-page) (license ,(match licenses @@ -117,6 +117,7 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." (let ((name (assoc-ref package "name")) (version (assoc-ref package "version")) (hash (assoc-ref package "sha")) + (synopsis (assoc-ref package "info")) ; nothing better to use (description (beautify-description (assoc-ref package "info"))) (home-page (assoc-ref package "homepage_uri")) @@ -129,5 +130,5 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." "runtime"))) (licenses (map string->license (assoc-ref package "licenses")))) - (make-gem-sexp name version hash home-page + (make-gem-sexp name version hash home-page synopsis description dependencies licenses))))) diff --git a/tests/gem.scm b/tests/gem.scm index 9efbda31fe..ebce809840 100644 --- a/tests/gem.scm +++ b/tests/gem.scm @@ -69,7 +69,7 @@ (("bundler" ('unquote 'bundler)) ("ruby-bar" ('unquote 'ruby-bar))))) ('synopsis "A cool gem") - ('description "A cool gem") + ('description "This package provides a cool gem") ('home-page "https://example.com") ('license ('list 'expat 'asl2.0))) #t) -- cgit v1.2.3 From a132f7d68f4c61133c0c97d8e5125c48f7205ac9 Mon Sep 17 00:00:00 2001 From: Ben Woodcroft Date: Sun, 17 Jan 2016 10:20:59 +1000 Subject: tests: Move beatify-description tests to import-tests. Fixes . * tests/cran.scm (beautify-description: use double spacing, beautify-description: transform fragment into sentence). Move from here ... * tests/import-utils.scm: ... to here. New file. * Makefile.am (SCM_TESTS): Add import-utils. --- Makefile.am | 3 ++- tests/cran.scm | 10 ---------- tests/import-utils.scm | 39 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 41 insertions(+), 11 deletions(-) create mode 100644 tests/import-utils.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 74bc8b5948..7e41990cac 100644 --- a/Makefile.am +++ b/Makefile.am @@ -241,7 +241,8 @@ SCM_TESTS = \ tests/cve.scm \ tests/file-systems.scm \ tests/services.scm \ - tests/containers.scm + tests/containers.scm \ + tests/import-utils.scm if HAVE_GUILE_JSON diff --git a/tests/cran.scm b/tests/cran.scm index e4f22353bd..83d2e7f554 100644 --- a/tests/cran.scm +++ b/tests/cran.scm @@ -86,16 +86,6 @@ Date/Publication: 2015-07-14 14:15:16 '() ((@@ (guix import cran) listify) simple-alist "BadList")) -(test-equal "beautify-description: use double spacing" - "This is a package. It is great. Trust me Mr. Hendrix." - ((@@ (guix import cran) beautify-description) - "This is a package. It is great. Trust me Mr. Hendrix.")) - -(test-equal "beautify-description: transform fragment into sentence" - "This package provides a function to establish world peace" - ((@@ (guix import cran) beautify-description) - "A function to establish world peace")) - (test-assert "description->package" ;; Replace network resources with sample data. (mock ((guix build download) url-fetch diff --git a/tests/import-utils.scm b/tests/import-utils.scm new file mode 100644 index 0000000000..08365816d4 --- /dev/null +++ b/tests/import-utils.scm @@ -0,0 +1,39 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ricardo Wurmus +;;; Copyright © 2016 Ben Woodcroft +;;; +;;; 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-import-utils) + #:use-module (guix tests) + #:use-module (guix import utils) + #:use-module (srfi srfi-64)) + +(test-begin "import-utils") + +(test-equal "beautify-description: use double spacing" + "This is a package. It is great. Trust me Mr. Hendrix." + (beautify-description + "This is a package. It is great. Trust me Mr. Hendrix.")) + +(test-equal "beautify-description: transform fragment into sentence" + "This package provides a function to establish world peace" + (beautify-description "A function to establish world peace")) + +(test-end "import-utils") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From 6b779207ee627c93fc0dad18ef67c149024fa535 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 21 Jan 2016 22:45:54 +0100 Subject: system: grub: Search root device by label or UUID if possible. Fixes . Reported by Christopher Allan Webber . * gnu/system/grub.scm (eye-candy): Add 'root-fs' parameter. Replace 'search --file' command in the output with whatever 'grub-root-search' returns. (grub-root-search): New procedure. (grub-configuration-file): Add 'store-fs' parameter. Use 'grub-root-search' instead of hard-coded 'search --file' commands. * gnu/system.scm (store-file-system, operating-system-store-file-system): New procedures. (operating-system-grub.cfg): Use it, and adjust call to 'grub-configuration-file'. * tests/system.scm: New file. * Makefile.am (SCM_TESTS): Add it. --- Makefile.am | 1 + gnu/system.scm | 26 +++++++++++++++++- gnu/system/grub.scm | 54 +++++++++++++++++++++++++++---------- tests/system.scm | 77 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 143 insertions(+), 15 deletions(-) create mode 100644 tests/system.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 7e41990cac..1ede6d4057 100644 --- a/Makefile.am +++ b/Makefile.am @@ -240,6 +240,7 @@ SCM_TESTS = \ tests/challenge.scm \ tests/cve.scm \ tests/file-systems.scm \ + tests/system.scm \ tests/services.scm \ tests/containers.scm \ tests/import-utils.scm diff --git a/gnu/system.scm b/gnu/system.scm index ee0280c069..edcfaf66fe 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -79,6 +79,7 @@ operating-system-locale-libcs operating-system-mapped-devices operating-system-file-systems + operating-system-store-file-system operating-system-activation-script operating-system-derivation @@ -678,12 +679,34 @@ listed in OS. The C library expects to find it under (package-version kernel) " (alpha)")) +(define (store-file-system file-systems) + "Return the file system object among FILE-SYSTEMS that contains the store." + (match (filter (lambda (fs) + (and (file-system-mount? fs) + (not (memq 'bind-mount (file-system-flags fs))) + (string-prefix? (file-system-mount-point fs) + (%store-prefix)))) + file-systems) + ((and candidates (head . tail)) + (reduce (lambda (fs1 fs2) + (if (> (string-length (file-system-mount-point fs1)) + (string-length (file-system-mount-point fs2))) + fs1 + fs2)) + head + candidates)))) + +(define (operating-system-store-file-system os) + "Return the file system that contains the store of OS." + (store-file-system (operating-system-file-systems os))) + (define* (operating-system-grub.cfg os #:optional (old-entries '())) "Return the GRUB configuration file for OS. Use OLD-ENTRIES to populate the \"old entries\" menu." (mlet* %store-monad ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) + (store-fs -> (operating-system-store-file-system os)) (kernel -> (operating-system-kernel os)) (root-device -> (if (eq? 'uuid (file-system-title root-fs)) (uuid->string (file-system-device root-fs)) @@ -698,7 +721,8 @@ listed in OS. The C library expects to find it under "/boot") (operating-system-kernel-arguments os))) (initrd #~(string-append #$system "/initrd")))))) - (grub-configuration-file (operating-system-bootloader os) entries + (grub-configuration-file (operating-system-bootloader os) + store-fs entries #:old-entries old-entries))) (define (operating-system-parameters-file os) diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 5b824820b1..45b46cae6f 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +25,7 @@ #:use-module (guix gexp) #:use-module (guix download) #:use-module (gnu artwork) + #:use-module (gnu system file-systems) #:autoload (gnu packages grub) (grub) #:autoload (gnu packages inkscape) (inkscape) #:autoload (gnu packages imagemagick) (imagemagick) @@ -153,10 +154,12 @@ WIDTH/HEIGHT, or #f if none was found." (with-monad %store-monad (return #f))))) -(define (eye-candy config system port) +(define (eye-candy config root-fs system port) "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the 'grub.cfg' part concerned with graphics mode, background images, colors, and -all that." +all that. ROOT-FS is a file-system object denoting the root file system where +the store is. SYSTEM must be the target system string---e.g., +\"x86_64-linux\"." (define setup-gfxterm-body ;; Intel systems need to be switched into graphics mode, whereas most ;; other modern architectures have no other mode and therefore don't need @@ -179,15 +182,18 @@ all that." (string-append (symbol->string (assoc-ref colors 'fg)) "/" (symbol->string (assoc-ref colors 'bg))))) + (define font-file + #~(string-append #$grub "/share/grub/unicode.pf2")) + (mlet* %store-monad ((image (grub-background-image config))) (return (and image #~(format #$port " function setup_gfxterm {~a} # Set 'root' to the partition that contains /gnu/store. -search --file --set ~a/share/grub/unicode.pf2 +~a -if loadfont ~a/share/grub/unicode.pf2; then +if loadfont ~a; then setup_gfxterm fi @@ -200,7 +206,9 @@ else set menu_color_highlight=white/blue fi~%" #$setup-gfxterm-body - #$grub #$grub + #$(grub-root-search root-fs font-file) + #$font-file + #$image #$(theme-colors grub-theme-color-normal) #$(theme-colors grub-theme-color-highlight)))))) @@ -210,13 +218,31 @@ fi~%" ;;; Configuration file. ;;; -(define* (grub-configuration-file config entries +(define (grub-root-search root-fs file) + "Return the GRUB 'search' command to look for ROOT-FS, which contains FILE, +a gexp. The result is a gexp that can be inserted in the grub.cfg-generation +code." + (case (file-system-title root-fs) + ;; Preferably refer to ROOT-FS by its UUID or label. This is more + ;; efficient and less ambiguous, see <>. + ((uuid) + (format #f "search --fs-uuid --set ~a" + (uuid->string (file-system-device root-fs)))) + ((label) + (format #f "search --label --set ~a" + (file-system-device root-fs))) + (else + ;; As a last resort, look for any device containing FILE. + #~(format #f "search --file --set ~a" #$file)))) + +(define* (grub-configuration-file config store-fs entries #:key (system (%current-system)) (old-entries '())) "Return the GRUB configuration file corresponding to CONFIG, a - object. OLD-ENTRIES is taken to be a list of menu -entries corresponding to old generations of the system." + object, and where the store is available at STORE-FS, a + object. OLD-ENTRIES is taken to be a list of menu entries +corresponding to old generations of the system." (define linux-image-name (if (string-prefix? "mips" system) "vmlinuz" @@ -229,18 +255,18 @@ entries corresponding to old generations of the system." (match-lambda (($ label linux arguments initrd) #~(format port "menuentry ~s { - # Set 'root' to the partition that contains the kernel. - search --file --set ~a/~a~% - + ~a linux ~a/~a ~a initrd ~a }~%" #$label - #$linux #$linux-image-name + #$(grub-root-search store-fs + #~(string-append #$linux "/" + #$linux-image-name)) #$linux #$linux-image-name (string-join (list #$@arguments)) #$initrd)))) - (mlet %store-monad ((sugar (eye-candy config system #~port))) + (mlet %store-monad ((sugar (eye-candy config store-fs system #~port))) (define builder #~(call-with-output-file #$output (lambda (port) diff --git a/tests/system.scm b/tests/system.scm new file mode 100644 index 0000000000..7e016a610b --- /dev/null +++ b/tests/system.scm @@ -0,0 +1,77 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 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-system) + #:use-module (gnu) + #:use-module (guix store) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +;; Test the (gnu system) module. + +(define %root-fs + (file-system + (device "my-root") + (title 'label) + (mount-point "/") + (type "ext4"))) + +(define %os + (operating-system + (host-name "komputilo") + (timezone "Europe/Berlin") + (locale "en_US.utf8") + (bootloader (grub-configuration (device "/dev/sdX"))) + (file-systems (cons %root-fs %base-file-systems)) + + (users %base-user-accounts))) + +(test-begin "system") + +(test-assert "operating-system-store-file-system" + ;; %BASE-FILE-SYSTEMS defines a bind-mount for /gnu/store, but this + ;; shouldn't be a problem. + (eq? %root-fs + (operating-system-store-file-system %os))) + +(test-assert "operating-system-store-file-system, prefix" + (let* ((gnu (file-system + (device "foobar") + (mount-point (dirname (%store-prefix))) + (type "ext5"))) + (os (operating-system + (inherit %os) + (file-systems (cons* gnu %root-fs + %base-file-systems))))) + (eq? gnu (operating-system-store-file-system os)))) + +(test-assert "operating-system-store-file-system, store" + (let* ((gnu (file-system + (device "foobar") + (mount-point (%store-prefix)) + (type "ext5"))) + (os (operating-system + (inherit %os) + (file-systems (cons* gnu %root-fs + %base-file-systems))))) + (eq? gnu (operating-system-store-file-system os)))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From c74f0cb2b871f59466e6fbfbc954d8fc1cbc3c9c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 21 Jan 2016 23:45:52 +0100 Subject: tests: Prevent 'http_proxy' from breaking Web server tests. * tests/lint.scm: Add call to 'unsetenv' to remove 'http_proxy'. * tests/publish.scm: Likewise. --- tests/lint.scm | 5 ++++- tests/publish.scm | 4 ++++ 2 files changed, 8 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/lint.scm b/tests/lint.scm index df82593a9e..b8dad13ceb 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt ;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2014, 2015 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. @@ -19,6 +19,9 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . +;; Avoid interference. +(unsetenv "http_proxy") + (define-module (test-lint) #:use-module (guix tests) #:use-module (guix download) diff --git a/tests/publish.scm b/tests/publish.scm index 4d72fdc468..0b92390900 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -16,6 +16,9 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . +;; Avoid interference. +(unsetenv "http_proxy") + (define-module (test-publish) #:use-module (guix scripts publish) #:use-module (guix tests) @@ -62,6 +65,7 @@ (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") 6789)) (loop)))) + (test-begin "publish") (test-equal "/nix-cache-info" -- cgit v1.2.3