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.

gnu/services/base.scm

@@ -38,6 +38,7 @@ (define-module (gnu services base)
   #: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 @@ (define (root-file-system-service)
 
 (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 @@ (define (wait-for-udevd)
                              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" "

gnu/system.scm

@@ -44,6 +44,7 @@ (define-module (gnu system)
   #: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 @@ (define-module (gnu system)
             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 @@ (define-module (gnu system)
             operating-system-grub.cfg
 
             %setuid-programs
-            %base-packages))
+            %base-packages
+
+            luks-device-mapping))
 
 ;;; Commentary:
 ;;;
@@ -96,6 +100,8 @@ (define-record-type* <operating-system> operating-system
   (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 @@ (define builder
 ;;; 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 @@ (define file-systems
                   (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
+            (map (lambda (fs)
-                  (($ <file-system> device title target type flags opts
+                   (match fs
-                                    #f check? create?)
+                     (($ <file-system> device title target type flags opts
-                   (file-system-service device target type
+                                       #f check? create?)
-                                        #:title title
+                      (file-system-service device target type
-                                        #:check? check?
+                                           #:title title
-                                        #:create-mount-point? create?
+                                           #:requirements (requirements fs)
-                                        #:options opts
+                                           #:check? check?
-                                        #:flags flags)))
+                                           #: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 @@ (define boot-file-systems
               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"))))

gnu/system/file-systems.scm

@@ -37,7 +37,13 @@ (define-module (gnu system file-systems)
             %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 @@ (define %base-file-systems
         %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

gnu/system/linux-initrd.scm

@@ -131,6 +131,7 @@ (define* (base-initrd file-systems
                       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'.