summaryrefslogtreecommitdiff
path: root/gnu/system.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-09-11 23:39:15 +0200
committerLudovic Courtès <ludo@gnu.org>2014-09-12 00:14:52 +0200
commit5dae0186dea1e72e73bf223161620cfeddef5a63 (patch)
tree7f8d7ef58c4a7eb35c0ae90b12d8e71ec51eabd2 /gnu/system.scm
parentee7bae3bbd2030d5f2cdb88e484e1c67a063e2a3 (diff)
downloadpatches-5dae0186dea1e72e73bf223161620cfeddef5a63.tar
patches-5dae0186dea1e72e73bf223161620cfeddef5a63.tar.gz
system: Add support for Linux-style mapped devices.
* gnu/system/file-systems.scm (<mapped-device>): New record type. * gnu/system.scm (<operating-system>)[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.
Diffstat (limited to 'gnu/system.scm')
-rw-r--r--gnu/system.scm67
1 files changed, 55 insertions, 12 deletions
diff --git a/gnu/system.scm b/gnu/system.scm
index 8a3f4f6ba8..9bdf227eca 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 <mapped-device>
+ (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
- (($ <file-system> 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
+ (($ <file-system> 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"))))