gnu/system/mapped-devices.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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     (match targets
 197       ((target)
 198        #~(let ((source #$(if (uuid? source)
 199                              (uuid-bytevector source)
 200                              source)))
 201            ;; XXX: 'use-modules' should be at the top level.
 202            (use-modules (rnrs bytevectors) ;bytevector?
 203                         ((gnu build file-systems)
 204                          #:select (find-partition-by-luks-uuid)))
 205
 206            ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
 207            ;; whole world inside the initrd (for when we're in an initrd).
 208            (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
 209                            "open" "--type" "luks"
 210
 211                            ;; Note: We cannot use the "UUID=source" syntax here
 212                            ;; because 'cryptsetup' implements it by searching the
 213                            ;; udev-populated /dev/disk/by-id directory but udev may
 214                            ;; be unavailable at the time we run this.
 215                            (if (bytevector? source)
 216                                (or (let loop ((tries-left 10))
 217                                      (and (positive? tries-left)
 218                                           (or (find-partition-by-luks-uuid source)
 219                                               ;; If the underlying partition is
 220                                               ;; not found, try again after
 221                                               ;; waiting a second, up to ten
 222                                               ;; times.  FIXME: This should be
 223                                               ;; dealt with in a more robust way.
 224                                               (begin (sleep 1)
 225                                                      (loop (- tries-left 1))))))
 226                                    (error "LUKS partition not found" source))
 227                                source)
 228
 229                            #$target)))))))
 230
 231 (define (close-luks-device source targets)
 232   "Return a gexp that closes TARGET, a LUKS device."
 233   (match targets
 234     ((target)
 235      #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
 236                        "close" #$target)))))
 237
 238 (define* (check-luks-device md #:key
 239                             needed-for-boot?
 240                             (initrd-modules '())
 241                             #:allow-other-keys
 242                             #:rest rest)
 243   "Ensure the source of MD is valid."
 244   (let ((source   (mapped-device-source md))
 245         (location (mapped-device-location md)))
 246     (or (not (zero? (getuid)))
 247         (if (uuid? source)
 248             (match (find-partition-by-luks-uuid (uuid-bytevector source))
 249               (#f
 250                (raise (make-compound-condition
 251                        (formatted-message (G_ "no LUKS partition with UUID '~a'")
 252                                           (uuid->string source))
 253                        (condition
 254                         (&error-location
 255                          (location (source-properties->location
 256                                     (mapped-device-location md))))))))
 257               ((? string? device)
 258                (check-device-initrd-modules device initrd-modules location)))
 259             (check-device-initrd-modules source initrd-modules location)))))
 260
 261 (define luks-device-mapping
 262   ;; The type of LUKS mapped devices.
 263   (mapped-device-kind
 264    (open open-luks-device)
 265    (close close-luks-device)
 266    (check check-luks-device)))
 267
 268 (define (open-raid-device sources targets)
 269   "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
 270 TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
 271   (match targets
 272     ((target)
 273      #~(let ((sources '#$sources)
 274
 275              ;; XXX: We're not at the top level here.  We could use a
 276              ;; non-top-level 'use-modules' form but that doesn't work when the
 277              ;; code is eval'd, like the Shepherd does.
 278              (every   (@ (srfi srfi-1) every))
 279              (format  (@ (ice-9 format) format)))
 280          (let loop ((attempts 0))
 281            (unless (every file-exists? sources)
 282              (when (> attempts 20)
 283                (error "RAID devices did not show up; bailing out"
 284                       sources))
 285
 286              (format #t "waiting for RAID source devices~{ ~a~}...~%"
 287                      sources)
 288              (sleep 1)
 289              (loop (+ 1 attempts))))
 290
 291          ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
 292          ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
 293          (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
 294                        "--assemble" #$target sources))))))
 295
 296 (define (close-raid-device sources targets)
 297   "Return a gexp that stops the RAID device TARGET."
 298   (match targets
 299     ((target)
 300      #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
 301                        "--stop" #$target)))))
 302
 303 (define raid-device-mapping
 304   ;; The type of RAID mapped devices.
 305   (mapped-device-kind
 306    (open open-raid-device)
 307    (close close-raid-device)))
 308
 309 (define (open-lvm-device source targets)
 310   #~(and
 311      (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
 312                      "vgchange" "--activate" "ay" #$source))
 313      ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
 314      (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
 315                      "vgscan" "--mknodes"))
 316      (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
 317                               '#$targets))))
 318
 319
 320 (define (close-lvm-device source targets)
 321   #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
 322                     "vgchange" "--activate" "n" #$source)))
 323
 324 (define lvm-device-mapping
 325   (mapped-device-kind
 326    (open open-lvm-device)
 327    (close close-lvm-device)))
 328
 329 ;;; mapped-devices.scm ends here