gnu/system/mapped-devices.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
   4 ;;; Copyright © 2017, 2018 Mark H Weaver <mhw@netris.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu system mapped-devices)
  22   #:use-module (guix gexp)
  23   #:use-module (guix records)
  24   #:use-module ((guix modules) #:hide (file-name->module-name))
  25   #:use-module (guix i18n)
  26   #:use-module ((guix diagnostics)
  27                 #:select (source-properties->location
  28                           formatted-message
  29                           &fix-hint
  30                           &error-location))
  31   #:use-module (guix deprecation)
  32   #:use-module (gnu services)
  33   #:use-module (gnu services shepherd)
  34   #:use-module (gnu system uuid)
  35   #:autoload   (gnu build file-systems) (find-partition-by-luks-uuid)
  36   #:autoload   (gnu build linux-modules)
  37                  (missing-modules)
  38   #:autoload   (gnu packages cryptsetup) (cryptsetup-static)
  39   #:autoload   (gnu packages linux) (mdadm-static lvm2-static)
  40   #:use-module (srfi srfi-1)
  41   #:use-module (srfi srfi-26)
  42   #:use-module (srfi srfi-34)
  43   #:use-module (srfi srfi-35)
  44   #:use-module (ice-9 match)
  45   #:use-module (ice-9 format)
  46   #:export (%mapped-device
  47             mapped-device
  48             mapped-device?
  49             mapped-device-source
  50             mapped-device-target
  51             mapped-device-targets
  52             mapped-device-type
  53             mapped-device-location
  54
  55             mapped-device-kind
  56             mapped-device-kind?
  57             mapped-device-kind-open
  58             mapped-device-kind-close
  59             mapped-device-kind-check
  60
  61             device-mapping-service-type
  62             device-mapping-service
  63
  64             check-device-initrd-modules           ;XXX: needs a better place
  65
  66             luks-device-mapping
  67             raid-device-mapping
  68             lvm-device-mapping))
  69
  70 ;;; Commentary:
  71 ;;;
  72 ;;; This module supports "device mapping", a concept implemented by Linux's
  73 ;;; device-mapper.
  74 ;;;
  75 ;;; Code:
  76
  77 (define-record-type* <mapped-device> %mapped-device
  78   make-mapped-device
  79   mapped-device?
  80   (source    mapped-device-source)                ;string | list of strings
  81   (targets   mapped-device-targets)               ;list of strings
  82   (type      mapped-device-type)                  ;<mapped-device-kind>
  83   (location  mapped-device-location
  84              (default (current-source-location)) (innate)))
  85
  86 (define-syntax mapped-device-compatibility-helper
  87   (syntax-rules (target)
  88     ((_ () (fields ...))
  89      (%mapped-device fields ...))
  90     ((_ ((target exp) rest ...) (others ...))
  91      (%mapped-device others ...
  92                       (targets (list exp))
  93                       rest ...))
  94     ((_ (field rest ...) (others ...))
  95      (mapped-device-compatibility-helper (rest ...)
  96                                          (others ... field)))))
  97
  98 (define-syntax-rule (mapped-device fields ...)
  99   "Build an <mapped-device> record, automatically converting 'target' field
 100 specifications to 'targets'."
 101   (mapped-device-compatibility-helper (fields ...) ()))
 102
 103 (define-deprecated (mapped-device-target md)
 104   mapped-device-targets
 105   (car (mapped-device-targets md)))
 106
 107 (define-record-type* <mapped-device-type> mapped-device-kind
 108   make-mapped-device-kind
 109   mapped-device-kind?
 110   (open      mapped-device-kind-open)             ;source target -> gexp
 111   (close     mapped-device-kind-close             ;source target -> gexp
 112              (default (const #~(const #f))))
 113   (check     mapped-device-kind-check             ;source -> Boolean
 114              (default (const #t))))
 115
 116 \f
 117 ;;;
 118 ;;; Device mapping as a Shepherd service.
 119 ;;;
 120
 121 (define device-mapping-service-type
 122   (shepherd-service-type
 123    'device-mapping
 124    (match-lambda
 125      (($ <mapped-device> source targets
 126                          ($ <mapped-device-type> open close))
 127       (shepherd-service
 128        (provision (list (symbol-append 'device-mapping- (string->symbol (string-join targets "-")))))
 129        (requirement '(udev))
 130        (documentation "Map a device node using Linux's device mapper.")
 131        (start #~(lambda () #$(open source targets)))
 132        (stop #~(lambda _ (not #$(close source targets))))
 133        (respawn? #f))))
 134    (description "Map a device node using Linux's device mapper.")))
 135
 136 (define (device-mapping-service mapped-device)
 137   "Return a service that sets up @var{mapped-device}."
 138   (service device-mapping-service-type mapped-device))
 139
 140 \f
 141 ;;;
 142 ;;; Static checks.
 143 ;;;
 144
 145 (define (check-device-initrd-modules device linux-modules location)
 146   "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate.
 147 DEVICE must be a \"/dev\" file name."
 148   (define missing
 149     ;; Attempt to determine missing modules.
 150     (catch 'system-error
 151       (lambda ()
 152         (missing-modules device linux-modules))
 153
 154       ;; If we can't do that (e.g., EPERM), skip the whole thing.
 155       (const '())))
 156
 157   (unless (null? missing)
 158     ;; Note: What we suggest here is a list of module names (e.g.,
 159     ;; "usb_storage"), not file names (e.g., "usb-storage.ko").  This is
 160     ;; OK because we have machinery that accepts both the hyphen and the
 161     ;; underscore version.
 162     (raise (make-compound-condition
 163             (formatted-message (G_ "you may need these modules \
 164 in the initrd for ~a:~{ ~a~}")
 165                                device missing)
 166             (condition
 167              (&fix-hint
 168               (hint (format #f (G_ "Try adding them to the
 169 @code{initrd-modules} field of your @code{operating-system} declaration, along
 170 these lines:
 171
 172 @example
 173  (operating-system
 174    ;; @dots{}
 175    (initrd-modules (append (list~{ ~s~})
 176                            %base-initrd-modules)))
 177 @end example
 178
 179 If you think this diagnostic is inaccurate, use the @option{--skip-checks}
 180 option of @command{guix system}.\n")
 181                             missing))))
 182             (condition
 183              (&error-location
 184               (location (source-properties->location location))))))))
 185
 186 \f
 187 ;;;
 188 ;;; Common device mappings.
 189 ;;;
 190
 191 (define (open-luks-device source targets)
 192   "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
 193 'cryptsetup'."
 194   (with-imported-modules (source-module-closure
 195                           '((gnu build file-systems)
 196                             (guix build utils))) ;; For mkdir-p
 197     (match targets
 198       ((target)
 199        #~(let ((source #$(if (uuid? source)
 200                              (uuid-bytevector source)
 201                              source)))
 202            ;; XXX: 'use-modules' should be at the top level.
 203            (use-modules (rnrs bytevectors) ;bytevector?
 204                         ((gnu build file-systems)
 205                          #:select (find-partition-by-luks-uuid
 206                                    system*/tty))
 207                         ((guix build utils) #:select (mkdir-p)))
 208
 209            ;; Create '/run/cryptsetup/' if it does not exist, as device locking
 210            ;; is mandatory for LUKS2.
 211            (mkdir-p "/run/cryptsetup/")
 212
 213            ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
 214            ;; whole world inside the initrd (for when we're in an initrd).
 215            ;; 'cryptsetup open' requires standard input to be a tty to allow
 216            ;; for interaction but shepherd sets standard input to /dev/null;
 217            ;; thus, explicitly request a tty.
 218            (zero? (system*/tty
 219                    #$(file-append cryptsetup-static "/sbin/cryptsetup")
 220                    "open" "--type" "luks"
 221
 222                    ;; Note: We cannot use the "UUID=source" syntax here
 223                    ;; because 'cryptsetup' implements it by searching the
 224                    ;; udev-populated /dev/disk/by-id directory but udev may
 225                    ;; be unavailable at the time we run this.
 226                    (if (bytevector? source)
 227                        (or (let loop ((tries-left 10))
 228                              (and (positive? tries-left)
 229                                   (or (find-partition-by-luks-uuid source)
 230                                       ;; If the underlying partition is
 231                                       ;; not found, try again after
 232                                       ;; waiting a second, up to ten
 233                                       ;; times.  FIXME: This should be
 234                                       ;; dealt with in a more robust way.
 235                                       (begin (sleep 1)
 236                                              (loop (- tries-left 1))))))
 237                            (error "LUKS partition not found" source))
 238                        source)
 239
 240                    #$target)))))))
 241
 242 (define (close-luks-device source targets)
 243   "Return a gexp that closes TARGET, a LUKS device."
 244   (match targets
 245     ((target)
 246      #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
 247                        "close" #$target)))))
 248
 249 (define* (check-luks-device md #:key
 250                             needed-for-boot?
 251                             (initrd-modules '())
 252                             #:allow-other-keys
 253                             #:rest rest)
 254   "Ensure the source of MD is valid."
 255   (let ((source   (mapped-device-source md))
 256         (location (mapped-device-location md)))
 257     (or (not (zero? (getuid)))
 258         (if (uuid? source)
 259             (match (find-partition-by-luks-uuid (uuid-bytevector source))
 260               (#f
 261                (raise (make-compound-condition
 262                        (formatted-message (G_ "no LUKS partition with UUID '~a'")
 263                                           (uuid->string source))
 264                        (condition
 265                         (&error-location
 266                          (location (source-properties->location
 267                                     (mapped-device-location md))))))))
 268               ((? string? device)
 269                (check-device-initrd-modules device initrd-modules location)))
 270             (check-device-initrd-modules source initrd-modules location)))))
 271
 272 (define luks-device-mapping
 273   ;; The type of LUKS mapped devices.
 274   (mapped-device-kind
 275    (open open-luks-device)
 276    (close close-luks-device)
 277    (check check-luks-device)))
 278
 279 (define (open-raid-device sources targets)
 280   "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
 281 TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
 282   (match targets
 283     ((target)
 284      #~(let ((sources '#$sources)
 285
 286              ;; XXX: We're not at the top level here.  We could use a
 287              ;; non-top-level 'use-modules' form but that doesn't work when the
 288              ;; code is eval'd, like the Shepherd does.
 289              (every   (@ (srfi srfi-1) every))
 290              (format  (@ (ice-9 format) format)))
 291          (let loop ((attempts 0))
 292            (unless (every file-exists? sources)
 293              (when (> attempts 20)
 294                (error "RAID devices did not show up; bailing out"
 295                       sources))
 296
 297              (format #t "waiting for RAID source devices~{ ~a~}...~%"
 298                      sources)
 299              (sleep 1)
 300              (loop (+ 1 attempts))))
 301
 302          ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
 303          ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
 304          (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
 305                        "--assemble" #$target sources))))))
 306
 307 (define (close-raid-device sources targets)
 308   "Return a gexp that stops the RAID device TARGET."
 309   (match targets
 310     ((target)
 311      #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
 312                        "--stop" #$target)))))
 313
 314 (define raid-device-mapping
 315   ;; The type of RAID mapped devices.
 316   (mapped-device-kind
 317    (open open-raid-device)
 318    (close close-raid-device)))
 319
 320 (define (open-lvm-device source targets)
 321   #~(and
 322      (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
 323                      "vgchange" "--activate" "ay" #$source))
 324      ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
 325      (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
 326                      "vgscan" "--mknodes"))
 327      (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
 328                               '#$targets))))
 329
 330
 331 (define (close-lvm-device source targets)
 332   #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
 333                     "vgchange" "--activate" "n" #$source)))
 334
 335 (define lvm-device-mapping
 336   (mapped-device-kind
 337    (open open-lvm-device)
 338    (close close-lvm-device)))
 339
 340 ;;; mapped-devices.scm ends here