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.
This commit is contained in:
Ludovic Courtès 2014-09-11 23:39:15 +02:00
parent ee7bae3bbd
commit 5dae0186de
4 changed files with 97 additions and 16 deletions

View File

@ -38,6 +38,7 @@
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:export (root-file-system-service #:export (root-file-system-service
file-system-service file-system-service
device-mapping-service
user-processes-service user-processes-service
host-name-service host-name-service
console-font-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 (define* (file-system-service device target type
#:key (flags '()) (check? #t) #: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 "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 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 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, 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, 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 (with-monad %store-monad
(return (return
(service (service
(provision (list (symbol-append 'file-system- (string->symbol target)))) (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.") (documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args (start #~(lambda args
(let ((device (canonicalize-device-spec #$device '#$title))) (let ((device (canonicalize-device-spec #$device '#$title)))
@ -567,6 +570,21 @@ extra rules from the packages listed in @var{rules}."
pid))))) pid)))))
(stop #~(make-kill-destructor)))))) (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 (define %base-services
;; Convenience variable holding the basic services. ;; Convenience variable holding the basic services.
(let ((motd (text-file "motd" " (let ((motd (text-file "motd" "

View File

@ -44,6 +44,7 @@
#:use-module (gnu system linux) #:use-module (gnu system linux)
#:use-module (gnu system linux-initrd) #:use-module (gnu system linux-initrd)
#:use-module (gnu system file-systems) #:use-module (gnu system file-systems)
#:autoload (gnu packages cryptsetup) (cryptsetup)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -64,6 +65,7 @@
operating-system-packages operating-system-packages
operating-system-timezone operating-system-timezone
operating-system-locale operating-system-locale
operating-system-mapped-devices
operating-system-file-systems operating-system-file-systems
operating-system-activation-script operating-system-activation-script
@ -72,7 +74,9 @@
operating-system-grub.cfg operating-system-grub.cfg
%setuid-programs %setuid-programs
%base-packages)) %base-packages
luks-device-mapping))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -96,6 +100,8 @@
(hosts-file operating-system-hosts-file ; M item | #f (hosts-file operating-system-hosts-file ; M item | #f
(default #f)) (default #f))
(mapped-devices operating-system-mapped-devices ; list of <mapped-device>
(default '()))
(file-systems operating-system-file-systems) ; list of fs (file-systems operating-system-file-systems) ; list of fs
(users operating-system-users ; list of user accounts (users operating-system-users ; list of user accounts
@ -152,6 +158,13 @@ file."
;;; Services. ;;; 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) (define (other-file-system-services os)
"Return file system services for the file systems of OS that are not marked "Return file system services for the file systems of OS that are not marked
as 'needed-for-boot'." as 'needed-for-boot'."
@ -161,30 +174,58 @@ as 'needed-for-boot'."
(string=? "/" (file-system-mount-point fs)))) (string=? "/" (file-system-mount-point fs))))
(operating-system-file-systems os))) (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 (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))) 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) (define (essential-services os)
"Return the list of essential services for OS. These are special services "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 that implement part of what's declared in OS are responsible for low-level
bookkeeping." 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)) (other-fs (other-file-system-services os))
(procs (user-processes-service (procs (user-processes-service
(map (compose first service-provision) (map (compose first service-provision)
other-fs))) other-fs)))
(host-name (host-name-service (host-name (host-name-service
(operating-system-host-name os)))) (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) (define (operating-system-services os)
"Return all the services of OS, including \"internal\" services that do not "Return all the services of OS, including \"internal\" services that do not
@ -490,6 +531,8 @@ we're running in the final root."
boot?)) boot?))
(operating-system-file-systems os))) (operating-system-file-systems os)))
;; TODO: Pass the mapped devices required by boot-time file systems to the
;; initrd.
(mlet %store-monad (mlet %store-monad
((initrd ((operating-system-initrd os) boot-file-systems))) ((initrd ((operating-system-initrd os) boot-file-systems)))
(return #~(string-append #$initrd "/initrd")))) (return #~(string-append #$initrd "/initrd"))))

View File

@ -37,7 +37,13 @@
%pseudo-terminal-file-system %pseudo-terminal-file-system
%devtmpfs-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: ;;; Commentary:
;;; ;;;
@ -128,4 +134,17 @@
%pseudo-terminal-file-system %pseudo-terminal-file-system
%shared-memory-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 ;;; file-systems.scm ends here

View File

@ -131,6 +131,7 @@ initrd code."
volatile-root? volatile-root?
(extra-modules '()) (extra-modules '())
guile-modules-in-chroot?) guile-modules-in-chroot?)
;; TODO: Support boot-time device mappings.
"Return a monadic derivation that builds a generic initrd. FILE-SYSTEMS is "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 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'. the root file system specified on the kernel command line via '--root'.