| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 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 utils) |
| 27 | #:select (source-properties->location |
| 28 | &fix-hint |
| 29 | &error-location)) |
| 30 | #:use-module (gnu services) |
| 31 | #:use-module (gnu services shepherd) |
| 32 | #:use-module (gnu system uuid) |
| 33 | #:autoload (gnu build file-systems) (find-partition-by-luks-uuid) |
| 34 | #:autoload (gnu build linux-modules) |
| 35 | (missing-modules) |
| 36 | #:autoload (gnu packages cryptsetup) (cryptsetup-static) |
| 37 | #:autoload (gnu packages linux) (mdadm-static) |
| 38 | #:use-module (srfi srfi-1) |
| 39 | #:use-module (srfi srfi-26) |
| 40 | #:use-module (srfi srfi-34) |
| 41 | #:use-module (srfi srfi-35) |
| 42 | #:use-module (ice-9 match) |
| 43 | #:export (mapped-device |
| 44 | mapped-device? |
| 45 | mapped-device-source |
| 46 | mapped-device-target |
| 47 | mapped-device-type |
| 48 | mapped-device-location |
| 49 | |
| 50 | mapped-device-kind |
| 51 | mapped-device-kind? |
| 52 | mapped-device-kind-open |
| 53 | mapped-device-kind-close |
| 54 | mapped-device-kind-check |
| 55 | |
| 56 | device-mapping-service-type |
| 57 | device-mapping-service |
| 58 | |
| 59 | check-device-initrd-modules ;XXX: needs a better place |
| 60 | |
| 61 | luks-device-mapping |
| 62 | raid-device-mapping)) |
| 63 | |
| 64 | ;;; Commentary: |
| 65 | ;;; |
| 66 | ;;; This module supports "device mapping", a concept implemented by Linux's |
| 67 | ;;; device-mapper. |
| 68 | ;;; |
| 69 | ;;; Code: |
| 70 | |
| 71 | (define-record-type* <mapped-device> mapped-device |
| 72 | make-mapped-device |
| 73 | mapped-device? |
| 74 | (source mapped-device-source) ;string | list of strings |
| 75 | (target mapped-device-target) ;string |
| 76 | (type mapped-device-type) ;<mapped-device-kind> |
| 77 | (location mapped-device-location |
| 78 | (default (current-source-location)) (innate))) |
| 79 | |
| 80 | (define-record-type* <mapped-device-type> mapped-device-kind |
| 81 | make-mapped-device-kind |
| 82 | mapped-device-kind? |
| 83 | (open mapped-device-kind-open) ;source target -> gexp |
| 84 | (close mapped-device-kind-close ;source target -> gexp |
| 85 | (default (const #~(const #f)))) |
| 86 | (check mapped-device-kind-check ;source -> Boolean |
| 87 | (default (const #t)))) |
| 88 | |
| 89 | \f |
| 90 | ;;; |
| 91 | ;;; Device mapping as a Shepherd service. |
| 92 | ;;; |
| 93 | |
| 94 | (define device-mapping-service-type |
| 95 | (shepherd-service-type |
| 96 | 'device-mapping |
| 97 | (match-lambda |
| 98 | (($ <mapped-device> source target |
| 99 | ($ <mapped-device-type> open close)) |
| 100 | (shepherd-service |
| 101 | (provision (list (symbol-append 'device-mapping- (string->symbol target)))) |
| 102 | (requirement '(udev)) |
| 103 | (documentation "Map a device node using Linux's device mapper.") |
| 104 | (start #~(lambda () #$(open source target))) |
| 105 | (stop #~(lambda _ (not #$(close source target)))) |
| 106 | (respawn? #f)))))) |
| 107 | |
| 108 | (define (device-mapping-service mapped-device) |
| 109 | "Return a service that sets up @var{mapped-device}." |
| 110 | (service device-mapping-service-type mapped-device)) |
| 111 | |
| 112 | \f |
| 113 | ;;; |
| 114 | ;;; Static checks. |
| 115 | ;;; |
| 116 | |
| 117 | (define (check-device-initrd-modules device linux-modules location) |
| 118 | "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate. |
| 119 | DEVICE must be a \"/dev\" file name." |
| 120 | (define missing |
| 121 | ;; Attempt to determine missing modules. |
| 122 | (catch 'system-error |
| 123 | (lambda () |
| 124 | (missing-modules device linux-modules)) |
| 125 | |
| 126 | ;; If we can't do that (e.g., EPERM), skip the whole thing. |
| 127 | (const '()))) |
| 128 | |
| 129 | (unless (null? missing) |
| 130 | ;; Note: What we suggest here is a list of module names (e.g., |
| 131 | ;; "usb_storage"), not file names (e.g., "usb-storage.ko"). This is |
| 132 | ;; OK because we have machinery that accepts both the hyphen and the |
| 133 | ;; underscore version. |
| 134 | (raise (condition |
| 135 | (&message |
| 136 | (message (format #f (G_ "you may need these modules \ |
| 137 | in the initrd for ~a:~{ ~a~}") |
| 138 | device missing))) |
| 139 | (&fix-hint |
| 140 | (hint (format #f (G_ "Try adding them to the |
| 141 | @code{initrd-modules} field of your @code{operating-system} declaration, along |
| 142 | these lines: |
| 143 | |
| 144 | @example |
| 145 | (operating-system |
| 146 | ;; @dots{} |
| 147 | (initrd-modules (append (list~{ ~s~}) |
| 148 | %base-initrd-modules))) |
| 149 | @end example |
| 150 | |
| 151 | If you think this diagnostic is inaccurate, use the @option{--skip-checks} |
| 152 | option of @command{guix system}.\n") |
| 153 | missing))) |
| 154 | (&error-location |
| 155 | (location (source-properties->location location))))))) |
| 156 | |
| 157 | \f |
| 158 | ;;; |
| 159 | ;;; Common device mappings. |
| 160 | ;;; |
| 161 | |
| 162 | (define (open-luks-device source target) |
| 163 | "Return a gexp that maps SOURCE to TARGET as a LUKS device, using |
| 164 | 'cryptsetup'." |
| 165 | (with-imported-modules (source-module-closure |
| 166 | '((gnu build file-systems))) |
| 167 | #~(let ((source #$(if (uuid? source) |
| 168 | (uuid-bytevector source) |
| 169 | source))) |
| 170 | ;; XXX: 'use-modules' should be at the top level. |
| 171 | (use-modules (rnrs bytevectors) ;bytevector? |
| 172 | ((gnu build file-systems) |
| 173 | #:select (find-partition-by-luks-uuid))) |
| 174 | |
| 175 | ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the |
| 176 | ;; whole world inside the initrd (for when we're in an initrd). |
| 177 | (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") |
| 178 | "open" "--type" "luks" |
| 179 | |
| 180 | ;; Note: We cannot use the "UUID=source" syntax here |
| 181 | ;; because 'cryptsetup' implements it by searching the |
| 182 | ;; udev-populated /dev/disk/by-id directory but udev may |
| 183 | ;; be unavailable at the time we run this. |
| 184 | (if (bytevector? source) |
| 185 | (or (let loop ((tries-left 10)) |
| 186 | (and (positive? tries-left) |
| 187 | (or (find-partition-by-luks-uuid source) |
| 188 | ;; If the underlying partition is |
| 189 | ;; not found, try again after |
| 190 | ;; waiting a second, up to ten |
| 191 | ;; times. FIXME: This should be |
| 192 | ;; dealt with in a more robust way. |
| 193 | (begin (sleep 1) |
| 194 | (loop (- tries-left 1)))))) |
| 195 | (error "LUKS partition not found" source)) |
| 196 | source) |
| 197 | |
| 198 | #$target))))) |
| 199 | |
| 200 | (define (close-luks-device source target) |
| 201 | "Return a gexp that closes TARGET, a LUKS device." |
| 202 | #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") |
| 203 | "close" #$target))) |
| 204 | |
| 205 | (define* (check-luks-device md #:key |
| 206 | needed-for-boot? |
| 207 | (initrd-modules '()) |
| 208 | #:allow-other-keys |
| 209 | #:rest rest) |
| 210 | "Ensure the source of MD is valid." |
| 211 | (let ((source (mapped-device-source md)) |
| 212 | (location (mapped-device-location md))) |
| 213 | (or (not (zero? (getuid))) |
| 214 | (if (uuid? source) |
| 215 | (match (find-partition-by-luks-uuid (uuid-bytevector source)) |
| 216 | (#f |
| 217 | (raise (condition |
| 218 | (&message |
| 219 | (message (format #f (G_ "no LUKS partition with UUID '~a'") |
| 220 | (uuid->string source)))) |
| 221 | (&error-location |
| 222 | (location (source-properties->location |
| 223 | (mapped-device-location md))))))) |
| 224 | ((? string? device) |
| 225 | (check-device-initrd-modules device initrd-modules location))) |
| 226 | (check-device-initrd-modules source initrd-modules location))))) |
| 227 | |
| 228 | (define luks-device-mapping |
| 229 | ;; The type of LUKS mapped devices. |
| 230 | (mapped-device-kind |
| 231 | (open open-luks-device) |
| 232 | (close close-luks-device) |
| 233 | (check check-luks-device))) |
| 234 | |
| 235 | (define (open-raid-device sources target) |
| 236 | "Return a gexp that assembles SOURCES (a list of devices) to the RAID device |
| 237 | TARGET (e.g., \"/dev/md0\"), using 'mdadm'." |
| 238 | #~(let ((sources '#$sources) |
| 239 | |
| 240 | ;; XXX: We're not at the top level here. We could use a |
| 241 | ;; non-top-level 'use-modules' form but that doesn't work when the |
| 242 | ;; code is eval'd, like the Shepherd does. |
| 243 | (every (@ (srfi srfi-1) every)) |
| 244 | (format (@ (ice-9 format) format))) |
| 245 | (let loop ((attempts 0)) |
| 246 | (unless (every file-exists? sources) |
| 247 | (when (> attempts 20) |
| 248 | (error "RAID devices did not show up; bailing out" |
| 249 | sources)) |
| 250 | |
| 251 | (format #t "waiting for RAID source devices~{ ~a~}...~%" |
| 252 | sources) |
| 253 | (sleep 1) |
| 254 | (loop (+ 1 attempts)))) |
| 255 | |
| 256 | ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole |
| 257 | ;; closure (80 MiB) in the initrd when a RAID device is needed for boot. |
| 258 | (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm") |
| 259 | "--assemble" #$target sources)))) |
| 260 | |
| 261 | (define (close-raid-device sources target) |
| 262 | "Return a gexp that stops the RAID device TARGET." |
| 263 | #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm") |
| 264 | "--stop" #$target))) |
| 265 | |
| 266 | (define raid-device-mapping |
| 267 | ;; The type of RAID mapped devices. |
| 268 | (mapped-device-kind |
| 269 | (open open-raid-device) |
| 270 | (close close-raid-device))) |
| 271 | |
| 272 | ;;; mapped-devices.scm ends here |