blob: 2706e255c536578baa1fecc49ad07ca9b1a496cd (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
;;; 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 (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))))))
(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'."
#~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
"open" "--type" "luks"
#$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
|
