123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213 |
- ;;; GNU Guix --- Functional package management for GNU
- ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
- ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
- ;;; Copyright © 2017 Mark H Weaver <mhw@netris.org>
- ;;;
- ;;; This file is part of GNU Guix.
- ;;;
- ;;; GNU Guix is free software; you can redistribute it and/or modify it
- ;;; under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation; either version 3 of the License, or (at
- ;;; your option) any later version.
- ;;;
- ;;; GNU Guix is distributed in the hope that it will be useful, but
- ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
- (define-module (gnu system mapped-devices)
- #:use-module (guix gexp)
- #:use-module (guix records)
- #:use-module (guix modules)
- #:use-module (guix i18n)
- #:use-module ((guix utils)
- #:select (source-properties->location
- &error-location))
- #:use-module (gnu services)
- #:use-module (gnu services shepherd)
- #:use-module (gnu system uuid)
- #:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
- #:autoload (gnu packages cryptsetup) (cryptsetup-static)
- #:autoload (gnu packages linux) (mdadm-static)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
- #:use-module (ice-9 match)
- #:export (mapped-device
- mapped-device?
- mapped-device-source
- mapped-device-target
- mapped-device-type
- mapped-device-location
- mapped-device-kind
- mapped-device-kind?
- mapped-device-kind-open
- mapped-device-kind-close
- mapped-device-kind-check
- device-mapping-service-type
- device-mapping-service
- luks-device-mapping
- raid-device-mapping))
- ;;; Commentary:
- ;;;
- ;;; This module supports "device mapping", a concept implemented by Linux's
- ;;; device-mapper.
- ;;;
- ;;; Code:
- (define-record-type* <mapped-device> mapped-device
- make-mapped-device
- mapped-device?
- (source mapped-device-source) ;string | list of strings
- (target mapped-device-target) ;string
- (type mapped-device-type) ;<mapped-device-kind>
- (location mapped-device-location
- (default (current-source-location)) (innate)))
- (define-record-type* <mapped-device-type> mapped-device-kind
- make-mapped-device-kind
- mapped-device-kind?
- (open mapped-device-kind-open) ;source target -> gexp
- (close mapped-device-kind-close ;source target -> gexp
- (default (const #~(const #f))))
- (check mapped-device-kind-check ;source -> Boolean
- (default (const #t))))
- ;;;
- ;;; Device mapping as a Shepherd service.
- ;;;
- (define device-mapping-service-type
- (shepherd-service-type
- 'device-mapping
- (match-lambda
- (($ <mapped-device> source target
- ($ <mapped-device-type> open close))
- (shepherd-service
- (provision (list (symbol-append 'device-mapping- (string->symbol target))))
- (requirement '(udev))
- (documentation "Map a device node using Linux's device mapper.")
- (start #~(lambda () #$(open source target)))
- (stop #~(lambda _ (not #$(close source target))))
- (respawn? #f))))))
- (define (device-mapping-service mapped-device)
- "Return a service that sets up @var{mapped-device}."
- (service device-mapping-service-type mapped-device))
- ;;;
- ;;; Common device mappings.
- ;;;
- (define (open-luks-device source target)
- "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
- 'cryptsetup'."
- (with-imported-modules (source-module-closure
- '((gnu build file-systems)))
- #~(let ((source #$(if (uuid? source)
- (uuid-bytevector source)
- source)))
- ;; XXX: 'use-modules' should be at the top level.
- (use-modules (rnrs bytevectors) ;bytevector?
- ((gnu build file-systems)
- #:select (find-partition-by-luks-uuid)))
- ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
- ;; whole world inside the initrd (for when we're in an initrd).
- (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
- "open" "--type" "luks"
- ;; Note: We cannot use the "UUID=source" syntax here
- ;; because 'cryptsetup' implements it by searching the
- ;; udev-populated /dev/disk/by-id directory but udev may
- ;; be unavailable at the time we run this.
- (if (bytevector? source)
- (or (let loop ((tries-left 10))
- (and (positive? tries-left)
- (or (find-partition-by-luks-uuid source)
- ;; If the underlying partition is
- ;; not found, try again after
- ;; waiting a second, up to ten
- ;; times. FIXME: This should be
- ;; dealt with in a more robust way.
- (begin (sleep 1)
- (loop (- tries-left 1))))))
- (error "LUKS partition not found" source))
- source)
- #$target)))))
- (define (close-luks-device source target)
- "Return a gexp that closes TARGET, a LUKS device."
- #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
- "close" #$target)))
- (define (check-luks-device md)
- "Ensure the source of MD is valid."
- (let ((source (mapped-device-source md)))
- (or (not (uuid? source))
- (not (zero? (getuid)))
- (find-partition-by-luks-uuid (uuid-bytevector source))
- (raise (condition
- (&message
- (message (format #f (G_ "no LUKS partition with UUID '~a'")
- (uuid->string source))))
- (&error-location
- (location (source-properties->location
- (mapped-device-location md)))))))))
- (define luks-device-mapping
- ;; The type of LUKS mapped devices.
- (mapped-device-kind
- (open open-luks-device)
- (close close-luks-device)
- (check check-luks-device)))
- (define (open-raid-device sources target)
- "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
- TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
- #~(let ((sources '#$sources)
- ;; XXX: We're not at the top level here. We could use a
- ;; non-top-level 'use-modules' form but that doesn't work when the
- ;; code is eval'd, like the Shepherd does.
- (every (@ (srfi srfi-1) every))
- (format (@ (ice-9 format) format)))
- (let loop ((attempts 0))
- (unless (every file-exists? sources)
- (when (> attempts 20)
- (error "RAID devices did not show up; bailing out"
- sources))
- (format #t "waiting for RAID source devices~{ ~a~}...~%"
- sources)
- (sleep 1)
- (loop (+ 1 attempts))))
- ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
- ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
- (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
- "--assemble" #$target sources))))
- (define (close-raid-device sources target)
- "Return a gexp that stops the RAID device TARGET."
- #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
- "--stop" #$target)))
- (define raid-device-mapping
- ;; The type of RAID mapped devices.
- (mapped-device-kind
- (open open-raid-device)
- (close close-raid-device)))
- ;;; mapped-devices.scm ends here
|