diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/file-systems.scm | 31 | ||||
| -rw-r--r-- | gnu/system/install.scm | 2 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 10 | ||||
| -rw-r--r-- | gnu/system/mapped-devices.scm | 130 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 4 |
5 files changed, 142 insertions, 35 deletions
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index d0726d2b61..7e8c4489dd 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -54,17 +54,6 @@ %base-file-systems %container-file-systems - mapped-device - mapped-device? - mapped-device-source - mapped-device-target - mapped-device-type - - mapped-device-kind - mapped-device-kind? - mapped-device-kind-open - mapped-device-kind-close - <file-system-mapping> file-system-mapping file-system-mapping? @@ -293,26 +282,6 @@ initrd code." (create-mount-point? #t) (check? #f)))) - - -;;; -;;; Mapped devices, for Linux's device-mapper. -;;; - -(define-record-type* <mapped-device> mapped-device - make-mapped-device - mapped-device? - (source mapped-device-source) ;string - (target mapped-device-target) ;string - (type mapped-device-type)) ;<mapped-device-kind> - -(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))))) - ;;; ;;; Shared file systems, for VMs/containers. diff --git a/gnu/system/install.scm b/gnu/system/install.scm index a94e3ab2d5..07ad3cbcb2 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -255,7 +255,7 @@ Welcome to the installation of the Guix System Distribution! There is NO WARRANTY, to the extent permitted by law. In particular, you may LOSE ALL YOUR DATA as a side effect of the installation process. Furthermore, -it is alpha software, so it may BREAK IN UNEXPECTED WAYS. +it is 'beta' software, so it may contain bugs. You have been warned. Thanks for being so brave. "))) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 8ca74104fb..484bce71c4 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -32,6 +32,7 @@ #:use-module ((gnu packages make-bootstrap) #:select (%guile-static-stripped)) #:use-module (gnu system file-systems) + #:use-module (gnu system mapped-devices) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -228,7 +229,14 @@ loaded at boot time in the order in which they appear." (use-modules (gnu build linux-boot) (guix build utils) (guix build bournish) ;add the 'bournish' meta-command - (srfi srfi-26)) + (srfi srfi-26) + + ;; FIXME: The following modules are for + ;; LUKS-DEVICE-MAPPING. We should instead propagate + ;; this info via gexps. + ((gnu build file-systems) + #:select (find-partition-by-luks-uuid)) + (rnrs bytevectors)) (with-output-to-port (%make-void-port "w") (lambda () diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm new file mode 100644 index 0000000000..450b4737ac --- /dev/null +++ b/gnu/system/mapped-devices.scm @@ -0,0 +1,130 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.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 (gnu services) + #:use-module (gnu services shepherd) + #:autoload (gnu packages cryptsetup) (cryptsetup) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:export (mapped-device + mapped-device? + mapped-device-source + mapped-device-target + mapped-device-type + + mapped-device-kind + mapped-device-kind? + mapped-device-kind-open + mapped-device-kind-close + + device-mapping-service-type + device-mapping-service + + luks-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 + (target mapped-device-target) ;string + (type mapped-device-type)) ;<mapped-device-kind> + +(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))))) + + +;;; +;;; 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) + + ;; Add the modules needed by LUKS-DEVICE-MAPPING. + ;; FIXME: This info should be propagated via gexps. + (modules `((rnrs bytevectors) ;bytevector? + ((gnu build file-systems) + #:select (find-partition-by-luks-uuid)) + ,@%default-modules)) + (imported-modules `((gnu build file-systems) + ,@%default-imported-modules))))))) + +(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'." + #~(let ((source #$source)) + (zero? (system* (string-append #$cryptsetup "/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 (find-partition-by-luks-uuid source) + (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* (string-append #$cryptsetup "/sbin/cryptsetup") + "close" #$target))) + +(define luks-device-mapping + ;; The type of LUKS mapped devices. + (mapped-device-kind + (open open-luks-device) + (close close-luks-device))) + +;;; mapped-devices.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 58a476a468..2fbef6a3fc 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -425,7 +425,7 @@ environment with the store shared with the host. MAPPINGS is a list of os #:key full-boot? - (disk-image-size (* (if full-boot? 500 15) (expt 2 20)))) + (disk-image-size (* (if full-boot? 500 30) (expt 2 20)))) "Return a derivation that builds a QEMU image of OS that shares its store with the host. @@ -480,7 +480,7 @@ with '-virtfs' options for the host file systems listed in SHARED-FS." (mappings '()) full-boot? (disk-image-size - (* (if full-boot? 500 15) + (* (if full-boot? 500 30) (expt 2 20)))) "Return a derivation that builds a script to run a virtual machine image of OS that shares its store with the host. |