From 70608adb4a054438a9dee4abcf63858f3d0dfded Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Sep 2014 22:26:05 +0200 Subject: linux-initrd: Copy all the script's closure to the initrd. * gnu/system/linux-initrd.scm (expression->initrd): Remove calls to 'imported-modules' and 'compiled-modules'. Use 'gexp->script' with EXP. Add the result to TO-COPY. Make /init a symlink to that script, and copy its closure into the "contents" directory. Add fake /proc/self/exe symlink. * gnu/build/linux-boot.scm (load-linux-module*): Add comment about mmap. * gnu/system/vm.scm (system-qemu-image/shared-store-script): Add "-m 256". This turns out to be needed for initrds containing things like e2fsck and several modules; with the default of 128 MiB, loading libahci.ko may fail with -1. --- gnu/system/linux-initrd.scm | 126 +++++++++++++++++++++----------------------- 1 file changed, 59 insertions(+), 67 deletions(-) (limited to 'gnu/system/linux-initrd.scm') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 627d17bac..b05cfc5bc 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -68,85 +68,77 @@ initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. - (define graph-files - (unfold-right zero? - number->string - 1- - (length to-copy))) - - (mlet %store-monad ((source (imported-modules modules)) - (compiled (compiled-modules modules)) - (module-dir (flat-linux-module-directory linux - linux-modules))) + (mlet* %store-monad ((init (gexp->script "init" exp + #:modules modules + #:guile guile)) + (to-copy -> (cons init to-copy)) + (module-dir (flat-linux-module-directory linux + linux-modules))) + (define graph-files + (unfold-right zero? + number->string + 1- + (length to-copy))) + (define builder ;; TODO: Move most of this code to (gnu build linux-initrd). #~(begin (use-modules (gnu build linux-initrd) (guix build utils) (guix build store-copy) - (ice-9 pretty-print) - (ice-9 popen) - (ice-9 match) - (ice-9 ftw) - (srfi srfi-26) (system base compile) (rnrs bytevectors) ((system foreign) #:select (sizeof))) - (let ((modules #$source) - (gos #$compiled) - (scm-dir (string-append "share/guile/" (effective-version))) - (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a" - (effective-version) - (if (eq? (native-endianness) (endianness little)) - "LE" - "BE") - (sizeof '*) - (effective-version)))) - (mkdir #$output) - (mkdir "contents") - - (with-directory-excursion "contents" - (copy-recursively #$guile ".") - (call-with-output-file "init" - (lambda (p) - (format p "#!/bin/guile -ds~%!#~%" #$guile) - (pretty-print '#$exp p))) - (chmod "init" #o555) - (chmod "bin/guile" #o555) - - ;; Copy Guile modules. - (chmod scm-dir #o777) - (copy-recursively modules scm-dir - #:follow-symlinks? #t) - (copy-recursively gos (string-append "lib/guile/" - (effective-version) "/ccache") - #:follow-symlinks? #t) - - ;; Compile `init'. + (mkdir #$output) + (mkdir "contents") + + (with-directory-excursion "contents" + ;; Copy Linux modules. + (mkdir "modules") + (copy-recursively #$module-dir "modules") + + ;; Populate the initrd's store. + (with-directory-excursion ".." + (populate-store '#$graph-files "contents")) + + ;; Make '/init'. + (symlink #$init "init") + + ;; Compile it. + (let* ((init (readlink "init")) + (scm-dir (string-append "share/guile/" (effective-version))) + (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a" + (effective-version) + (if (eq? (native-endianness) (endianness little)) + "LE" + "BE") + (sizeof '*) + (effective-version) + (dirname init)))) (mkdir-p go-dir) - (set! %load-path (cons modules %load-path)) - (set! %load-compiled-path (cons gos %load-compiled-path)) - (compile-file "init" + (compile-file init #:opts %auto-compilation-options - #:output-file (string-append go-dir "/init.go")) - - ;; Copy Linux modules. - (mkdir "modules") - (copy-recursively #$module-dir "modules") - - ;; Populate the initrd's store. - (with-directory-excursion ".." - (populate-store '#$graph-files "contents")) - - ;; Reset the timestamps of all the files that will make it in the - ;; initrd. - (for-each (cut utime <> 0 0 0 0) - (find-files "." ".*")) - - (write-cpio-archive (string-append #$output "/initrd") "." - #:cpio (string-append #$cpio "/bin/cpio") - #:gzip (string-append #$gzip "/bin/gzip")))))) + #:output-file (string-append go-dir "/" + (basename init) + ".go"))) + + ;; This hack allows Guile to find out where it is. See + ;; 'guile-relocatable.patch'. + (mkdir-p "proc/self") + (symlink (string-append #$guile "/bin/guile") "proc/self/exe") + (readlink "proc/self/exe") + + ;; Reset the timestamps of all the files that will make it in the + ;; initrd. + (for-each (lambda (file) + (unless (eq? 'symlink (stat:type (lstat file))) + (utime file 0 0 0 0))) + (find-files "." ".*")) + + (write-cpio-archive (string-append #$output "/initrd") "." + #:cpio (string-append #$cpio "/bin/cpio") + #:gzip (string-append #$gzip "/bin/gzip"))))) (gexp->derivation name builder #:modules '((guix build utils) -- cgit v1.3 From 1621cf97aa0b0e19a53366479abe19f602f5f9da Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Sep 2014 23:20:34 +0200 Subject: linux-initrd: Move initrd creation code to (guix build linux-initrd). * gnu/build/linux-initrd.scm (cache-compiled-file-name, compile-to-cache, build-initrd): New procedures. * gnu/system/linux-initrd.scm (expression->initrd)[builder]: Remove code now moved above. Use 'build-initrd'. --- gnu/build/linux-initrd.scm | 77 ++++++++++++++++++++++++++++++++++++++++++++- gnu/system/linux-initrd.scm | 63 +++++-------------------------------- 2 files changed, 84 insertions(+), 56 deletions(-) (limited to 'gnu/system/linux-initrd.scm') diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm index bf60137e8..2c0acb200 100644 --- a/gnu/build/linux-initrd.scm +++ b/gnu/build/linux-initrd.scm @@ -17,9 +17,15 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu build linux-initrd) + #:use-module (guix build utils) + #:use-module (guix build store-copy) + #:use-module (system base compile) + #:use-module (rnrs bytevectors) + #:use-module ((system foreign) #:select (sizeof)) #:use-module (ice-9 popen) #:use-module (ice-9 ftw) - #:export (write-cpio-archive)) + #:export (write-cpio-archive + build-initrd)) ;;; Commentary: ;;; @@ -69,4 +75,73 @@ COMPRESS? is true, compress it using GZIP. On success, return OUTPUT." output)) output)))) +(define (cache-compiled-file-name file) + "Return the file name of the in-cache .go file for FILE, relative to the +current directory. + +This is similar to what 'compiled-file-name' in (system base compile) does." + (let loop ((file file)) + (let ((target (false-if-exception (readlink file)))) + (if target + (loop target) + (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a" + (effective-version) + (if (eq? (native-endianness) (endianness little)) + "LE" + "BE") + (sizeof '*) + (effective-version) + file))))) + +(define (compile-to-cache file) + "Compile FILE to the cache." + (let ((compiled-file (cache-compiled-file-name file))) + (mkdir-p (dirname compiled-file)) + (compile-file file + #:opts %auto-compilation-options + #:output-file compiled-file))) + +(define* (build-initrd output + #:key + guile init + linux-module-directory + (references-graphs '()) + (cpio "cpio") + (gzip "gzip")) + "Write an initial RAM disk (initrd) to OUTPUT. The initrd starts the script +at INIT, running GUILE. It contains all the items referred to by +REFERENCES-GRAPHS, plus the Linux modules from LINUX-MODULE-DIRECTORY." + (mkdir "contents") + + ;; Copy the closures of all the items referenced in REFERENCES-GRAPHS. + (populate-store references-graphs "contents") + + (with-directory-excursion "contents" + ;; Copy Linux modules. + (mkdir "modules") + (copy-recursively linux-module-directory "modules") + + ;; Make '/init'. + (symlink init "init") + + ;; Compile it. + (compile-to-cache "init") + + ;; Allow Guile to find out where it is (XXX). See + ;; 'guile-relocatable.patch'. + (mkdir-p "proc/self") + (symlink (string-append guile "/bin/guile") "proc/self/exe") + (readlink "proc/self/exe") + + ;; Reset the timestamps of all the files that will make it in the initrd. + (for-each (lambda (file) + (unless (eq? 'symlink (stat:type (lstat file))) + (utime file 0 0 0 0))) + (find-files "." ".*")) + + (write-cpio-archive output "." + #:cpio cpio #:gzip gzip)) + + (delete-file-recursively "contents")) + ;;; linux-initrd.scm ends here diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index b05cfc5bc..c2c8722eb 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -81,64 +81,17 @@ initrd." (length to-copy))) (define builder - ;; TODO: Move most of this code to (gnu build linux-initrd). #~(begin - (use-modules (gnu build linux-initrd) - (guix build utils) - (guix build store-copy) - (system base compile) - (rnrs bytevectors) - ((system foreign) #:select (sizeof))) + (use-modules (gnu build linux-initrd)) (mkdir #$output) - (mkdir "contents") - - (with-directory-excursion "contents" - ;; Copy Linux modules. - (mkdir "modules") - (copy-recursively #$module-dir "modules") - - ;; Populate the initrd's store. - (with-directory-excursion ".." - (populate-store '#$graph-files "contents")) - - ;; Make '/init'. - (symlink #$init "init") - - ;; Compile it. - (let* ((init (readlink "init")) - (scm-dir (string-append "share/guile/" (effective-version))) - (go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a" - (effective-version) - (if (eq? (native-endianness) (endianness little)) - "LE" - "BE") - (sizeof '*) - (effective-version) - (dirname init)))) - (mkdir-p go-dir) - (compile-file init - #:opts %auto-compilation-options - #:output-file (string-append go-dir "/" - (basename init) - ".go"))) - - ;; This hack allows Guile to find out where it is. See - ;; 'guile-relocatable.patch'. - (mkdir-p "proc/self") - (symlink (string-append #$guile "/bin/guile") "proc/self/exe") - (readlink "proc/self/exe") - - ;; Reset the timestamps of all the files that will make it in the - ;; initrd. - (for-each (lambda (file) - (unless (eq? 'symlink (stat:type (lstat file))) - (utime file 0 0 0 0))) - (find-files "." ".*")) - - (write-cpio-archive (string-append #$output "/initrd") "." - #:cpio (string-append #$cpio "/bin/cpio") - #:gzip (string-append #$gzip "/bin/gzip"))))) + (build-initrd (string-append #$output "/initrd") + #:guile #$guile + #:init #$init + #:references-graphs '#$graph-files + #:linux-module-directory #$module-dir + #:cpio (string-append #$cpio "/bin/cpio") + #:gzip (string-append #$gzip "/bin/gzip")))) (gexp->derivation name builder #:modules '((guix build utils) -- cgit v1.3 From df650fa84e15bfd65245adcd454c0433ad8c6121 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Sep 2014 23:27:40 +0200 Subject: linux-initrd: Remove #:to-copy argument of 'expression->initrd'. * gnu/system/linux-initrd.scm (expression->initrd): Remove #:to-copy parameter. Remove 'graph-files', and adjust #:references-graphs arguments to just list INIT. (base-initrd): Remove #:to-copy argument. * doc/guix.texi (Initial RAM Disk): Adjust accordingly. --- doc/guix.texi | 10 +++++----- gnu/system/linux-initrd.scm | 19 +++++-------------- 2 files changed, 10 insertions(+), 19 deletions(-) (limited to 'gnu/system/linux-initrd.scm') diff --git a/doc/guix.texi b/doc/guix.texi index e0251f5ff..1e8a55e9a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3616,16 +3616,16 @@ program to run in that initrd. @deffn {Monadic Procedure} expression->initrd @var{exp} @ [#:guile %guile-static-stripped] [#:name "guile-initrd"] @ - [#:modules '()] [#:to-copy '()] [#:linux #f] @ + [#:modules '()] [#:linux #f] @ [#:linux-modules '()] Return a derivation that builds a Linux initrd (a gzipped cpio archive) containing @var{guile} and that evaluates @var{exp}, a G-expression, -upon booting. +upon booting. All the derivations referenced by @var{exp} are +automatically copied to the initrd. @var{linux-modules} is a list of @file{.ko} file names to be copied from -@var{linux} into the initrd. @var{to-copy} is a list of additional -derivations or packages to copy to the initrd. @var{modules} is a list -of Guile module names to be embedded in the initrd. +@var{linux} into the initrd. @var{modules} is a list of Guile module +names to be embedded in the initrd. @end deffn @node Invoking guix system diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index c2c8722eb..03ac24d45 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -54,15 +54,14 @@ (name "guile-initrd") (system (%current-system)) (modules '()) - (to-copy '()) (linux #f) (linux-modules '())) "Return a derivation that builds a Linux initrd (a gzipped cpio archive) -containing GUILE and that evaluates EXP, a G-expression, upon booting. +containing GUILE and that evaluates EXP, a G-expression, upon booting. All +the derivations referenced by EXP are automatically copied to the initrd. LINUX-MODULES is a list of '.ko' file names to be copied from LINUX into the -initrd. TO-COPY is a list of additional derivations or packages to copy to -the initrd. MODULES is a list of Guile module names to be embedded in the +initrd. MODULES is a list of Guile module names to be embedded in the initrd." ;; General Linux overview in `Documentation/early-userspace/README' and @@ -71,15 +70,8 @@ initrd." (mlet* %store-monad ((init (gexp->script "init" exp #:modules modules #:guile guile)) - (to-copy -> (cons init to-copy)) (module-dir (flat-linux-module-directory linux linux-modules))) - (define graph-files - (unfold-right zero? - number->string - 1- - (length to-copy))) - (define builder #~(begin (use-modules (gnu build linux-initrd)) @@ -88,7 +80,7 @@ initrd." (build-initrd (string-append #$output "/initrd") #:guile #$guile #:init #$init - #:references-graphs '#$graph-files + #:references-graphs '("closure") #:linux-module-directory #$module-dir #:cpio (string-append #$cpio "/bin/cpio") #:gzip (string-append #$gzip "/bin/gzip")))) @@ -97,7 +89,7 @@ initrd." #:modules '((guix build utils) (guix build store-copy) (gnu build linux-initrd)) - #:references-graphs (zip graph-files to-copy)))) + #:references-graphs `(("closure" ,init))))) (define (flat-linux-module-directory linux modules) "Return a flat directory containing the Linux kernel modules listed in @@ -229,7 +221,6 @@ exception and backtrace!)." #:modules '((guix build utils) (gnu build linux-boot) (gnu build file-systems)) - #:to-copy helper-packages #:linux linux-libre #:linux-modules linux-modules)) -- cgit v1.3 From 42d10464bedb43a9211d8bc187e668fe33272368 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Sep 2014 23:46:48 +0200 Subject: linux-initrd: Store Linux modules in a normal store directory. * gnu/system/linux-initrd.scm (expression->initrd): Remove #:linux and #:linux-modules parameters. Remove call to 'float-linux-module-directory'. (base-initrd): Add call to 'float-linux-module-directory'. Use it in #:linux-modules argument in the gexp. Remove #:linux and #:linux-modules arguments to 'expression->initrd'. * gnu/build/linux-initrd.scm (build-initrd): Remove #:linux-module-directory parameter. Don't create 'modules' sub-directory. * gnu/build/linux-boot.scm (boot-system): Mentin that LINUX-MODULES is a list of absolute file names. Don't prepend "/modules/" to LINUX-MODULES. * doc/guix.texi (Initial RAM Disk): Adjust accordingly. --- doc/guix.texi | 8 +++--- gnu/build/linux-boot.scm | 13 +++++---- gnu/build/linux-initrd.scm | 7 +---- gnu/system/linux-initrd.scm | 65 +++++++++++++++++++++------------------------ 4 files changed, 41 insertions(+), 52 deletions(-) (limited to 'gnu/system/linux-initrd.scm') diff --git a/doc/guix.texi b/doc/guix.texi index 1e8a55e9a..e3b0cf61f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3616,16 +3616,14 @@ program to run in that initrd. @deffn {Monadic Procedure} expression->initrd @var{exp} @ [#:guile %guile-static-stripped] [#:name "guile-initrd"] @ - [#:modules '()] [#:linux #f] @ - [#:linux-modules '()] + [#:modules '()] Return a derivation that builds a Linux initrd (a gzipped cpio archive) containing @var{guile} and that evaluates @var{exp}, a G-expression, upon booting. All the derivations referenced by @var{exp} are automatically copied to the initrd. -@var{linux-modules} is a list of @file{.ko} file names to be copied from -@var{linux} into the initrd. @var{modules} is a list of Guile module -names to be embedded in the initrd. +@var{modules} is a list of Guile module names to be embedded in the +initrd. @end deffn @node Invoking guix system diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 1312da6bb..fbc683c79 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -343,10 +343,11 @@ bailing out.~%root contents: ~s~%" (scandir "/")) volatile-root? (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by -first loading LINUX-MODULES, then setting up QEMU guest networking if -QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS, -and finally booting into the new root if any. The initrd supports kernel -command-line options '--load', '--root', and '--repl'. +first loading LINUX-MODULES (a list of absolute file names of '.ko' files), +then setting up QEMU guest networking if QEMU-GUEST-NETWORKING? is true, +mounting the file systems specified in MOUNTS, and finally booting into the +new root if any. The initrd supports kernel command-line options '--load', +'--root', and '--repl'. Mount the root file system, specified by the '--root' command-line argument, if any. @@ -384,9 +385,7 @@ to it are lost." (start-repl)) (display "loading kernel modules...\n") - (for-each (compose load-linux-module* - (cut string-append "/modules/" <>)) - linux-modules) + (for-each load-linux-module* linux-modules) (when qemu-guest-networking? (unless (configure-qemu-networking) diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm index 2c0acb200..54639bd31 100644 --- a/gnu/build/linux-initrd.scm +++ b/gnu/build/linux-initrd.scm @@ -104,23 +104,18 @@ This is similar to what 'compiled-file-name' in (system base compile) does." (define* (build-initrd output #:key guile init - linux-module-directory (references-graphs '()) (cpio "cpio") (gzip "gzip")) "Write an initial RAM disk (initrd) to OUTPUT. The initrd starts the script at INIT, running GUILE. It contains all the items referred to by -REFERENCES-GRAPHS, plus the Linux modules from LINUX-MODULE-DIRECTORY." +REFERENCES-GRAPHS." (mkdir "contents") ;; Copy the closures of all the items referenced in REFERENCES-GRAPHS. (populate-store references-graphs "contents") (with-directory-excursion "contents" - ;; Copy Linux modules. - (mkdir "modules") - (copy-recursively linux-module-directory "modules") - ;; Make '/init'. (symlink init "init") diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 03ac24d45..e83a9a5b2 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -34,6 +34,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:export (expression->initrd base-initrd)) @@ -53,25 +54,19 @@ (gzip gzip) (name "guile-initrd") (system (%current-system)) - (modules '()) - (linux #f) - (linux-modules '())) + (modules '())) "Return a derivation that builds a Linux initrd (a gzipped cpio archive) containing GUILE and that evaluates EXP, a G-expression, upon booting. All the derivations referenced by EXP are automatically copied to the initrd. -LINUX-MODULES is a list of '.ko' file names to be copied from LINUX into the -initrd. MODULES is a list of Guile module names to be embedded in the -initrd." +MODULES is a list of Guile module names to be embedded in the initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. - (mlet* %store-monad ((init (gexp->script "init" exp - #:modules modules - #:guile guile)) - (module-dir (flat-linux-module-directory linux - linux-modules))) + (mlet %store-monad ((init (gexp->script "init" exp + #:modules modules + #:guile guile))) (define builder #~(begin (use-modules (gnu build linux-initrd)) @@ -80,8 +75,8 @@ initrd." (build-initrd (string-append #$output "/initrd") #:guile #$guile #:init #$init + ;; Copy everything INIT refers to into the initrd. #:references-graphs '("closure") - #:linux-module-directory #$module-dir #:cpio (string-append #$cpio "/bin/cpio") #:gzip (string-append #$gzip "/bin/gzip")))) @@ -201,27 +196,29 @@ exception and backtrace!)." (list unionfs-fuse/static) '()))) - (expression->initrd - #~(begin - (use-modules (gnu build linux-boot) - (guix build utils) - (srfi srfi-26)) - - (with-output-to-port (%make-void-port "w") - (lambda () - (set-path-environment-variable "PATH" '("bin" "sbin") - '#$helper-packages))) - - (boot-system #:mounts '#$(map file-system->spec file-systems) - #:linux-modules '#$linux-modules - #:qemu-guest-networking? #$qemu-networking? - #:guile-modules-in-chroot? '#$guile-modules-in-chroot? - #:volatile-root? '#$volatile-root?)) - #:name "base-initrd" - #:modules '((guix build utils) - (gnu build linux-boot) - (gnu build file-systems)) - #:linux linux-libre - #:linux-modules linux-modules)) + (mlet %store-monad ((kodir (flat-linux-module-directory linux-libre + linux-modules))) + (expression->initrd + #~(begin + (use-modules (gnu build linux-boot) + (guix build utils) + (srfi srfi-26)) + + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") + '#$helper-packages))) + + (boot-system #:mounts '#$(map file-system->spec file-systems) + #:linux-modules (map (lambda (file) + (string-append #$kodir "/" file)) + '#$linux-modules) + #:qemu-guest-networking? #$qemu-networking? + #:guile-modules-in-chroot? '#$guile-modules-in-chroot? + #:volatile-root? '#$volatile-root?)) + #:name "base-initrd" + #:modules '((guix build utils) + (gnu build linux-boot) + (gnu build file-systems))))) ;;; linux-initrd.scm ends here -- cgit v1.3 From 5dae0186dea1e72e73bf223161620cfeddef5a63 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Sep 2014 23:39:15 +0200 Subject: system: Add support for Linux-style mapped devices. * gnu/system/file-systems.scm (): New record type. * gnu/system.scm ()[mapped-devices]: New field. (luks-device-mapping): New procedure. (other-file-system-services)[device-mappings, requirements]: New procedures. Pass #:requirements to 'file-system-service'. (device-mapping-services): New procedure. (essential-services): Use it. Append its result to the return value. (operating-system-initrd-file): Add comment. * gnu/services/base.scm (file-system-service): Add #:requirements parameter and honor it. (device-mapping-service): New procedure. * gnu/system/linux-initrd.scm (base-initrd): Add comment. --- gnu/services/base.scm | 24 ++++++++++++++-- gnu/system.scm | 67 +++++++++++++++++++++++++++++++++++++-------- gnu/system/file-systems.scm | 21 +++++++++++++- gnu/system/linux-initrd.scm | 1 + 4 files changed, 97 insertions(+), 16 deletions(-) (limited to 'gnu/system/linux-initrd.scm') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index bf5af8369..014eef053 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -38,6 +38,7 @@ #:use-module (ice-9 format) #:export (root-file-system-service file-system-service + device-mapping-service user-processes-service host-name-service console-font-service @@ -99,18 +100,20 @@ This service must be the root of the service dependency graph so that its (define* (file-system-service device target type #:key (flags '()) (check? #t) - create-mount-point? options (title 'any)) + create-mount-point? options (title 'any) + (requirements '())) "Return a service that mounts DEVICE on TARGET as a file system TYPE with OPTIONS. TITLE is a symbol specifying what kind of name DEVICE is: 'label for a partition label, 'device for a device file name, or 'any. When CHECK? is true, check the file system before mounting it. When CREATE-MOUNT-POINT? is true, create TARGET if it does not exist yet. FLAGS is a list of symbols, -such as 'read-only' etc." +such as 'read-only' etc. Optionally, REQUIREMENTS may be a list of service +names such as device-mapping services." (with-monad %store-monad (return (service (provision (list (symbol-append 'file-system- (string->symbol target)))) - (requirement '(root-file-system)) + (requirement `(root-file-system ,@requirements)) (documentation "Check, mount, and unmount the given file system.") (start #~(lambda args (let ((device (canonicalize-device-spec #$device '#$title))) @@ -567,6 +570,21 @@ extra rules from the packages listed in @var{rules}." pid))))) (stop #~(make-kill-destructor)))))) +(define (device-mapping-service target command) + "Return a service that maps device @var{target}, a string such as +@code{\"home\"} (meaning @code{/dev/mapper/home}), by executing @var{command}, +a gexp." + (with-monad %store-monad + (return (service + (provision (list (symbol-append 'device-mapping- + (string->symbol target)))) + (requirement '(udev)) + (documentation "Map a device node using Linux's device mapper.") + (start #~(lambda () + #$command)) + (stop #~(const #f)) + (respawn? #f))))) + (define %base-services ;; Convenience variable holding the basic services. (let ((motd (text-file "motd" " diff --git a/gnu/system.scm b/gnu/system.scm index 8a3f4f6ba..9bdf227ec 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -44,6 +44,7 @@ #:use-module (gnu system linux) #:use-module (gnu system linux-initrd) #:use-module (gnu system file-systems) + #:autoload (gnu packages cryptsetup) (cryptsetup) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -64,6 +65,7 @@ operating-system-packages operating-system-timezone operating-system-locale + operating-system-mapped-devices operating-system-file-systems operating-system-activation-script @@ -72,7 +74,9 @@ operating-system-grub.cfg %setuid-programs - %base-packages)) + %base-packages + + luks-device-mapping)) ;;; Commentary: ;;; @@ -96,6 +100,8 @@ (hosts-file operating-system-hosts-file ; M item | #f (default #f)) + (mapped-devices operating-system-mapped-devices ; list of + (default '())) (file-systems operating-system-file-systems) ; list of fs (users operating-system-users ; list of user accounts @@ -152,6 +158,13 @@ file." ;;; Services. ;;; +(define (luks-device-mapping source target) + "Return a gexp that maps SOURCE to TARGET as a LUKS device, using +'cryptsetup'." + #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") + "open" "--type" "luks" + #$source #$target))) + (define (other-file-system-services os) "Return file system services for the file systems of OS that are not marked as 'needed-for-boot'." @@ -161,30 +174,58 @@ as 'needed-for-boot'." (string=? "/" (file-system-mount-point fs)))) (operating-system-file-systems os))) + (define (device-mappings fs) + (filter (lambda (md) + (string=? (string-append "/dev/mapper/" + (mapped-device-target md)) + (file-system-device fs))) + (operating-system-mapped-devices os))) + + (define (requirements fs) + (map (lambda (md) + (symbol-append 'device-mapping- + (string->symbol (mapped-device-target md)))) + (device-mappings fs))) + (sequence %store-monad - (map (match-lambda - (($ device title target type flags opts - #f check? create?) - (file-system-service device target type - #:title title - #:check? check? - #:create-mount-point? create? - #:options opts - #:flags flags))) + (map (lambda (fs) + (match fs + (($ device title target type flags opts + #f check? create?) + (file-system-service device target type + #:title title + #:requirements (requirements fs) + #:check? check? + #:create-mount-point? create? + #:options opts + #:flags flags)))) file-systems))) +(define (device-mapping-services os) + "Return the list of device-mapping services for OS as a monadic list." + (sequence %store-monad + (map (lambda (md) + (let ((source (mapped-device-source md)) + (target (mapped-device-target md)) + (command (mapped-device-command md))) + (device-mapping-service target + (command source target)))) + (operating-system-mapped-devices os)))) + (define (essential-services os) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level bookkeeping." - (mlet* %store-monad ((root-fs (root-file-system-service)) + (mlet* %store-monad ((mappings (device-mapping-services os)) + (root-fs (root-file-system-service)) (other-fs (other-file-system-services os)) (procs (user-processes-service (map (compose first service-provision) other-fs))) (host-name (host-name-service (operating-system-host-name os)))) - (return (cons* host-name procs root-fs other-fs)))) + (return (cons* host-name procs root-fs + (append other-fs mappings))))) (define (operating-system-services os) "Return all the services of OS, including \"internal\" services that do not @@ -490,6 +531,8 @@ we're running in the final root." boot?)) (operating-system-file-systems os))) + ;; TODO: Pass the mapped devices required by boot-time file systems to the + ;; initrd. (mlet %store-monad ((initrd ((operating-system-initrd os) boot-file-systems))) (return #~(string-append #$initrd "/initrd")))) diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 48c4fc7e7..90e2b0c79 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -37,7 +37,13 @@ %pseudo-terminal-file-system %devtmpfs-file-system - %base-file-systems)) + %base-file-systems + + mapped-device + mapped-device? + mapped-device-source + mapped-device-target + mapped-device-command)) ;;; Commentary: ;;; @@ -128,4 +134,17 @@ %pseudo-terminal-file-system %shared-memory-file-system)) + + +;;; +;;; Mapped devices, for Linux's device-mapper. +;;; + +(define-record-type* mapped-device + make-mapped-device + mapped-device? + (source mapped-device-source) ;string + (target mapped-device-target) ;string + (command mapped-device-command)) ;source target -> gexp + ;;; file-systems.scm ends here diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index e83a9a5b2..93f751b75 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -131,6 +131,7 @@ initrd code." volatile-root? (extra-modules '()) guile-modules-in-chroot?) + ;; TODO: Support boot-time device mappings. "Return a monadic derivation that builds a generic initrd. FILE-SYSTEMS is a list of file-systems to be mounted by the initrd, possibly in addition to the root file system specified on the kernel command line via '--root'. -- cgit v1.3