aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/services/base.scm24
-rw-r--r--gnu/system.scm67
-rw-r--r--gnu/system/file-systems.scm21
-rw-r--r--gnu/system/linux-initrd.scm1
4 files changed, 97 insertions, 16 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index bf5af8369e..014eef053b 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 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"))))
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 48c4fc7e77..90e2b0c796 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> 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 e83a9a5b23..93f751b757 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'.