gnu/system/mapped-devices.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 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
 135 (define (device-mapping-service mapped-device)
 136   "Return a service that sets up @var{mapped-device}."
 137   (service device-mapping-service-type mapped-device))
 138
 139 \f
 140 ;;;
 141 ;;; Static checks.
 142 ;;;
 143
 144 (define (check-device-initrd-modules device linux-modules location)
 145   "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate.
 146 DEVICE must be a \"/dev\" file name."
 147   (define missing
 148     ;; Attempt to determine missing modules.
 149     (catch 'system-error
 150       (lambda ()
 151         (missing-modules device linux-modules))
 152
 153       ;; If we can't do that (e.g., EPERM), skip the whole thing.
 154       (const '())))
 155
 156   (unless (null? missing)
 157     ;; Note: What we suggest here is a list of module names (e.g.,
 158     ;; "usb_storage"), not file names (e.g., "usb-storage.ko").  This is
 159     ;; OK because we have machinery that accepts both the hyphen and the
 160     ;; underscore version.
 161     (raise (make-compound-condition
 162             (formatted-message (G_ "you may need these modules \
 163 in the initrd for ~a:~{ ~a~}")
 164                                device missing)
 165             (condition
 166              (&fix-hint
 167               (hint (format #f (G_ "Try adding them to the
 168 @code{initrd-modules} field of your @code{operating-system} declaration, along
 169 these lines:
 170
 171 @example
 172  (operating-system
 173    ;; @dots{}
 174    (initrd-modules (append (list~{ ~s~})
 175                            %base-initrd-modules)))
 176 @end example
 177
 178 If you think this diagnostic is inaccurate, use the @option{--skip-checks}
 179 option of @command{guix system}.\n")
 180                             missing))))
 181             (condition
 182              (&error-location
 183               (location (source-properties->location location))))))))
 184
 185 \f
 186 ;;;
 187 ;;; Common device mappings.
 188 ;;;
 189
 190 (define (open-luks-device source targets)
 191   "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
 192 'cryptsetup'."
 193   (with-imported-modules (source-module-closure
 194                           '((gnu build file-systems)))
 195     (match targets
 196       ((target)
 197        #~(let ((source #$(if (uuid? source)
 198                              (uuid-bytevector source)
 199                              source)))
 200            ;; XXX: 'use-modules' should be at the top level.
 201            (use-modules (rnrs bytevectors) ;bytevector?
 202                         ((gnu build file-systems)
 203                          #:select (find-partition-by-luks-uuid)))
 204
 205            ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
 206            ;; whole world inside the initrd (for when we're in an initrd).
 207            (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
 208                            "open" "--type" "luks"
 209
 210                            ;; Note: We cannot use the "UUID=source" syntax here
 211                            ;; because 'cryptsetup' implements it by searching the
 212                            ;; udev-populated /dev/disk/by-id directory but udev may
 213                            ;; be unavailable at the time we run this.
 214                            (if (bytevector? source)
 215                                (or (let loop ((tries-left 10))
 216                                      (and (positive? tries-left)
 217                                           (or (find-partition-by-luks-uuid source)
 218                                               ;; If the underlying partition is
 219                                               ;; not found, try again after
 220                                               ;; waiting a second, up to ten
 221                                               ;; times.  FIXME: This should be
 222                                               ;; dealt with in a more robust way.
 223                                               (begin (sleep 1)
 224                                                      (loop (- tries-left 1))))))
 225                                    (error "LUKS partition not found" source))
 226                                source)
 227
 228                            #$target)))))))
 229
 230 (define (close-luks-device source targets)
 231   "Return a gexp that closes TARGET, a LUKS device."
 232   (match targets
 233     ((target)
 234      #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
 235                        "close" #$target)))))
 236
 237 (define* (check-luks-device md #:key
 238                             needed-for-boot?
 239                             (initrd-modules '())
 240                             #:allow-other-keys
 241                             #:rest rest)
 242   "Ensure the source of MD is valid."
 243   (let ((source   (mapped-device-source md))
 244         (location (mapped-device-location md)))
 245     (or (not (zero? (getuid)))
 246         (if (uuid? source)
 247             (match (find-partition-by-luks-uuid (uuid-bytevector source))
 248               (#f
 249                (raise (make-compound-condition
 250                        (formatted-message (G_ "no LUKS partition with UUID '~a'")
 251                                           (uuid->string source))
 252                        (condition
 253                         (&error-location
 254                          (location (source-properties->location
 255                                     (mapped-device-location md))))))))
 256               ((? string? device)
 257                (check-device-initrd-modules device initrd-modules location)))
 258             (check-device-initrd-modules source initrd-modules location)))))
 259
 260 (define luks-device-mapping
 261   ;; The type of LUKS mapped devices.
 262   (mapped-device-kind
 263    (open open-luks-device)
 264    (close close-luks-device)
 265    (check check-luks-device)))
 266
 267 (define (open-raid-device sources targets)
 268   "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
 269 TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
 270   (match targets
 271     ((target)
 272      #~(let ((sources '#$sources)
 273
 274              ;; XXX: We're not at the top level here.  We could use a
 275              ;; non-top-level 'use-modules' form but that doesn't work when the
 276              ;; code is eval'd, like the Shepherd does.
 277              (every   (@ (srfi srfi-1) every))
 278              (format  (@ (ice-9 format) format)))
 279          (let loop ((attempts 0))
 280            (unless (every file-exists? sources)
 281              (when (> attempts 20)
 282                (error "RAID devices did not show up; bailing out"
 283                       sources))
 284
 285              (format #t "waiting for RAID source devices~{ ~a~}...~%"
 286                      sources)
 287              (sleep 1)
 288              (loop (+ 1 attempts))))
 289
 290          ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
 291          ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
 292          (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
 293                        "--assemble" #$target sources))))))
 294
 295 (define (close-raid-device sources targets)
 296   "Return a gexp that stops the RAID device TARGET."
 297   (match targets
 298     ((target)
 299      #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
 300                        "--stop" #$target)))))
 301
 302 (define raid-device-mapping
 303   ;; The type of RAID mapped devices.
 304   (mapped-device-kind
 305    (open open-raid-device)
 306    (close close-raid-device)))
 307
 308 (define (open-lvm-device source targets)
 309   #~(and
 310      (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
 311                      "vgchange" "--activate" "ay" #$source))
 312      ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
 313      (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
 314                      "vgscan" "--mknodes"))
 315      (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
 316                               '#$targets))))
 317
 318
 319 (define (close-lvm-device source targets)
 320   #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
 321                     "vgchange" "--activate" "n" #$source)))
 322
 323 (define lvm-device-mapping
 324   (mapped-device-kind
 325    (open open-lvm-device)
 326    (close close-lvm-device)))
 327
 328 ;;; mapped-devices.scm ends here