diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | gnu/system.scm | 26 | ||||
| -rw-r--r-- | gnu/system/grub.scm | 54 | ||||
| -rw-r--r-- | tests/system.scm | 77 |
4 files changed, 143 insertions, 15 deletions
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 <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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 -<grub-configuration> object. OLD-ENTRIES is taken to be a list of menu -entries corresponding to old generations of the system." +<grub-configuration> object, and where the store is available at STORE-FS, a +<file-system> 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 (($ <menu-entry> 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 <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-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)) |