mapped-devices.scm 8.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
  4. ;;; Copyright © 2017 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. (define-module (gnu system mapped-devices)
  21. #:use-module (guix gexp)
  22. #:use-module (guix records)
  23. #:use-module (guix modules)
  24. #:use-module (guix i18n)
  25. #:use-module ((guix utils)
  26. #:select (source-properties->location
  27. &error-location))
  28. #:use-module (gnu services)
  29. #:use-module (gnu services shepherd)
  30. #:use-module (gnu system uuid)
  31. #:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
  32. #:autoload (gnu packages cryptsetup) (cryptsetup-static)
  33. #:autoload (gnu packages linux) (mdadm-static)
  34. #:use-module (srfi srfi-1)
  35. #:use-module (srfi srfi-34)
  36. #:use-module (srfi srfi-35)
  37. #:use-module (ice-9 match)
  38. #:export (mapped-device
  39. mapped-device?
  40. mapped-device-source
  41. mapped-device-target
  42. mapped-device-type
  43. mapped-device-location
  44. mapped-device-kind
  45. mapped-device-kind?
  46. mapped-device-kind-open
  47. mapped-device-kind-close
  48. mapped-device-kind-check
  49. device-mapping-service-type
  50. device-mapping-service
  51. luks-device-mapping
  52. raid-device-mapping))
  53. ;;; Commentary:
  54. ;;;
  55. ;;; This module supports "device mapping", a concept implemented by Linux's
  56. ;;; device-mapper.
  57. ;;;
  58. ;;; Code:
  59. (define-record-type* <mapped-device> mapped-device
  60. make-mapped-device
  61. mapped-device?
  62. (source mapped-device-source) ;string | list of strings
  63. (target mapped-device-target) ;string
  64. (type mapped-device-type) ;<mapped-device-kind>
  65. (location mapped-device-location
  66. (default (current-source-location)) (innate)))
  67. (define-record-type* <mapped-device-type> mapped-device-kind
  68. make-mapped-device-kind
  69. mapped-device-kind?
  70. (open mapped-device-kind-open) ;source target -> gexp
  71. (close mapped-device-kind-close ;source target -> gexp
  72. (default (const #~(const #f))))
  73. (check mapped-device-kind-check ;source -> Boolean
  74. (default (const #t))))
  75. ;;;
  76. ;;; Device mapping as a Shepherd service.
  77. ;;;
  78. (define device-mapping-service-type
  79. (shepherd-service-type
  80. 'device-mapping
  81. (match-lambda
  82. (($ <mapped-device> source target
  83. ($ <mapped-device-type> open close))
  84. (shepherd-service
  85. (provision (list (symbol-append 'device-mapping- (string->symbol target))))
  86. (requirement '(udev))
  87. (documentation "Map a device node using Linux's device mapper.")
  88. (start #~(lambda () #$(open source target)))
  89. (stop #~(lambda _ (not #$(close source target))))
  90. (respawn? #f))))))
  91. (define (device-mapping-service mapped-device)
  92. "Return a service that sets up @var{mapped-device}."
  93. (service device-mapping-service-type mapped-device))
  94. ;;;
  95. ;;; Common device mappings.
  96. ;;;
  97. (define (open-luks-device source target)
  98. "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
  99. 'cryptsetup'."
  100. (with-imported-modules (source-module-closure
  101. '((gnu build file-systems)))
  102. #~(let ((source #$(if (uuid? source)
  103. (uuid-bytevector source)
  104. source)))
  105. ;; XXX: 'use-modules' should be at the top level.
  106. (use-modules (rnrs bytevectors) ;bytevector?
  107. ((gnu build file-systems)
  108. #:select (find-partition-by-luks-uuid)))
  109. ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
  110. ;; whole world inside the initrd (for when we're in an initrd).
  111. (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
  112. "open" "--type" "luks"
  113. ;; Note: We cannot use the "UUID=source" syntax here
  114. ;; because 'cryptsetup' implements it by searching the
  115. ;; udev-populated /dev/disk/by-id directory but udev may
  116. ;; be unavailable at the time we run this.
  117. (if (bytevector? source)
  118. (or (let loop ((tries-left 10))
  119. (and (positive? tries-left)
  120. (or (find-partition-by-luks-uuid source)
  121. ;; If the underlying partition is
  122. ;; not found, try again after
  123. ;; waiting a second, up to ten
  124. ;; times. FIXME: This should be
  125. ;; dealt with in a more robust way.
  126. (begin (sleep 1)
  127. (loop (- tries-left 1))))))
  128. (error "LUKS partition not found" source))
  129. source)
  130. #$target)))))
  131. (define (close-luks-device source target)
  132. "Return a gexp that closes TARGET, a LUKS device."
  133. #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
  134. "close" #$target)))
  135. (define (check-luks-device md)
  136. "Ensure the source of MD is valid."
  137. (let ((source (mapped-device-source md)))
  138. (or (not (uuid? source))
  139. (not (zero? (getuid)))
  140. (find-partition-by-luks-uuid (uuid-bytevector source))
  141. (raise (condition
  142. (&message
  143. (message (format #f (G_ "no LUKS partition with UUID '~a'")
  144. (uuid->string source))))
  145. (&error-location
  146. (location (source-properties->location
  147. (mapped-device-location md)))))))))
  148. (define luks-device-mapping
  149. ;; The type of LUKS mapped devices.
  150. (mapped-device-kind
  151. (open open-luks-device)
  152. (close close-luks-device)
  153. (check check-luks-device)))
  154. (define (open-raid-device sources target)
  155. "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
  156. TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
  157. #~(let ((sources '#$sources)
  158. ;; XXX: We're not at the top level here. We could use a
  159. ;; non-top-level 'use-modules' form but that doesn't work when the
  160. ;; code is eval'd, like the Shepherd does.
  161. (every (@ (srfi srfi-1) every))
  162. (format (@ (ice-9 format) format)))
  163. (let loop ((attempts 0))
  164. (unless (every file-exists? sources)
  165. (when (> attempts 20)
  166. (error "RAID devices did not show up; bailing out"
  167. sources))
  168. (format #t "waiting for RAID source devices~{ ~a~}...~%"
  169. sources)
  170. (sleep 1)
  171. (loop (+ 1 attempts))))
  172. ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
  173. ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
  174. (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
  175. "--assemble" #$target sources))))
  176. (define (close-raid-device sources target)
  177. "Return a gexp that stops the RAID device TARGET."
  178. #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
  179. "--stop" #$target)))
  180. (define raid-device-mapping
  181. ;; The type of RAID mapped devices.
  182. (mapped-device-kind
  183. (open open-raid-device)
  184. (close close-raid-device)))
  185. ;;; mapped-devices.scm ends here