Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

272 lines
10 KiB

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