#: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
(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)))
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" "
#: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)
operating-system-packages
operating-system-timezone
operating-system-locale
+ operating-system-mapped-devices
operating-system-file-systems
operating-system-activation-script
operating-system-grub.cfg
%setuid-programs
- %base-packages))
+ %base-packages
+
+ luks-device-mapping))
;;; Commentary:
;;;
(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
;;; 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'."
(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
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"))))
HCoop / jackhill / guix / guix.git / commitdiff