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