;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2017, 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (gnu system mapped-devices)
#:use-module (guix gexp)
#:use-module (guix records)
+ #:use-module (guix modules)
+ #:use-module (guix i18n)
+ #:use-module ((guix utils)
+ #:select (source-properties->location
+ &fix-hint
+ &error-location))
#:use-module (gnu services)
#:use-module (gnu services shepherd)
- #:autoload (gnu packages cryptsetup) (cryptsetup)
- #:autoload (gnu packages linux) (mdadm)
+ #:use-module (gnu system uuid)
+ #:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
+ #:autoload (gnu build linux-modules)
+ (device-module-aliases matching-modules known-module-aliases
+ normalize-module-name)
+ #:autoload (gnu packages cryptsetup) (cryptsetup-static)
+ #:autoload (gnu packages linux) (mdadm-static)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:export (mapped-device
mapped-device?
mapped-device-source
mapped-device-target
mapped-device-type
+ mapped-device-location
mapped-device-kind
mapped-device-kind?
mapped-device-kind-open
mapped-device-kind-close
+ mapped-device-kind-check
device-mapping-service-type
device-mapping-service
+ check-device-initrd-modules ;XXX: needs a better place
+
luks-device-mapping
raid-device-mapping))
(define-record-type* <mapped-device> mapped-device
make-mapped-device
mapped-device?
- (source mapped-device-source) ;string
+ (source mapped-device-source) ;string | list of strings
(target mapped-device-target) ;string
- (type mapped-device-type)) ;<mapped-device-kind>
+ (type mapped-device-type) ;<mapped-device-kind>
+ (location mapped-device-location
+ (default (current-source-location)) (innate)))
(define-record-type* <mapped-device-type> mapped-device-kind
make-mapped-device-kind
mapped-device-kind?
(open mapped-device-kind-open) ;source target -> gexp
(close mapped-device-kind-close ;source target -> gexp
- (default (const #~(const #f)))))
+ (default (const #~(const #f))))
+ (check mapped-device-kind-check ;source -> Boolean
+ (default (const #t))))
\f
;;;
(service device-mapping-service-type mapped-device))
\f
+;;;
+;;; Static checks.
+;;;
+
+(define (check-device-initrd-modules device linux-modules location)
+ "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate.
+DEVICE must be a \"/dev\" file name."
+ (define aliases
+ ;; Attempt to load 'modules.alias' from the current kernel, assuming we're
+ ;; on GuixSD, and assuming that corresponds to the kernel we'll be
+ ;; installing. Skip the whole thing if that file cannot be read.
+ (catch 'system-error
+ (lambda ()
+ (known-module-aliases))
+ (const #f)))
+
+ (when aliases
+ (let ((modules (delete-duplicates
+ (append-map (cut matching-modules <> aliases)
+ (device-module-aliases device))))
+
+ ;; Module names (not file names) are supposed to use underscores
+ ;; instead of hyphens. MODULES is a list of module names, whereas
+ ;; LINUX-MODULES is file names without '.ko', so normalize them.
+ (provided (map normalize-module-name linux-modules)))
+ (unless (every (cut member <> provided) modules)
+ (raise (condition
+ (&message
+ (message (format #f (G_ "you may need these modules \
+in the initrd for ~a:~{ ~a~}")
+ device modules)))
+ (&fix-hint
+ (hint (format #f (G_ "Try adding them to the
+@code{initrd-modules} field of your @code{operating-system} declaration, along
+these lines:
+
+@example
+ (operating-system
+ ;; @dots{}
+ (initrd-modules (append (list~{ ~s~})
+ %base-initrd-modules)))
+@end example\n")
+ modules)))
+ (&error-location
+ (location (source-properties->location location)))))))))
+
+\f
;;;
;;; Common device mappings.
;;;
(define (open-luks-device source target)
"Return a gexp that maps SOURCE to TARGET as a LUKS device, using
'cryptsetup'."
- (with-imported-modules '((gnu build file-systems)
- (guix build bournish))
- #~(let ((source #$source))
+ (with-imported-modules (source-module-closure
+ '((gnu build file-systems)))
+ #~(let ((source #$(if (uuid? source)
+ (uuid-bytevector source)
+ source)))
;; XXX: 'use-modules' should be at the top level.
(use-modules (rnrs bytevectors) ;bytevector?
((gnu build file-systems)
#:select (find-partition-by-luks-uuid)))
- (zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
+ ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
+ ;; whole world inside the initrd (for when we're in an initrd).
+ (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
"open" "--type" "luks"
;; Note: We cannot use the "UUID=source" syntax here
;; udev-populated /dev/disk/by-id directory but udev may
;; be unavailable at the time we run this.
(if (bytevector? source)
- (or (find-partition-by-luks-uuid source)
+ (or (let loop ((tries-left 10))
+ (and (positive? tries-left)
+ (or (find-partition-by-luks-uuid source)
+ ;; If the underlying partition is
+ ;; not found, try again after
+ ;; waiting a second, up to ten
+ ;; times. FIXME: This should be
+ ;; dealt with in a more robust way.
+ (begin (sleep 1)
+ (loop (- tries-left 1))))))
(error "LUKS partition not found" source))
source)
(define (close-luks-device source target)
"Return a gexp that closes TARGET, a LUKS device."
- #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
+ #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
"close" #$target)))
+(define* (check-luks-device md #:key
+ needed-for-boot?
+ (initrd-modules '())
+ #:allow-other-keys
+ #:rest rest)
+ "Ensure the source of MD is valid."
+ (let ((source (mapped-device-source md))
+ (location (mapped-device-location md)))
+ (or (not (zero? (getuid)))
+ (if (uuid? source)
+ (match (find-partition-by-luks-uuid (uuid-bytevector source))
+ (#f
+ (raise (condition
+ (&message
+ (message (format #f (G_ "no LUKS partition with UUID '~a'")
+ (uuid->string source))))
+ (&error-location
+ (location (source-properties->location
+ (mapped-device-location md)))))))
+ ((? string? device)
+ (check-device-initrd-modules device initrd-modules location)))
+ (check-device-initrd-modules source initrd-modules location)))))
+
(define luks-device-mapping
;; The type of LUKS mapped devices.
(mapped-device-kind
(open open-luks-device)
- (close close-luks-device)))
+ (close close-luks-device)
+ (check check-luks-device)))
(define (open-raid-device sources target)
"Return a gexp that assembles SOURCES (a list of devices) to the RAID device
(sleep 1)
(loop (+ 1 attempts))))
- (zero? (system* (string-append #$mdadm "/sbin/mdadm")
- "--assemble" #$target sources))))
+ ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
+ ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
+ (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
+ "--assemble" #$target sources))))
(define (close-raid-device sources target)
"Return a gexp that stops the RAID device TARGET."
- #~(zero? (system* (string-append #$mdadm "/sbin/mdadm")
+ #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
"--stop" #$target)))
(define raid-device-mapping
HCoop / jackhill / guix / guix.git / blobdiff