ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 13:28:12 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

system: Add support for Linux-style mapped devices.

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

24
gnu/services/base.scm
View file

@ -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" "

53
gnu/system.scm
View file

@ -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)
(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)))
#: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"))))

21
gnu/system/file-systems.scm
View file

@ -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

1
gnu/system/linux-initrd.scm
View file

@ -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'.