system: Define 'device-mapping-kind', and add a 'close' procedure.
* gnu/system/file-systems.scm (<mapped-device-type>): New record type. (<mapped-device>)[command]: Remove field. [type]: New field. * gnu/services/base.scm (device-mapping-service): Rename 'command' parameter to 'open'. Add 'close' parameter and honor it. * gnu/system.scm (luks-device-mapping): Rename to... (open-luks-device): ... this. (close-luks-device): New procedure. (luks-device-mapping): New variable. (device-mapping-services): Get the type of MD, and pass its 'open' and 'close' fields to 'device-mapping-service'.
This commit is contained in:
parent
cb823dd279
commit
722554a306
|
@ -600,19 +600,18 @@ extra rules from the packages listed in @var{rules}."
|
|||
;; called. Thus, make sure it is not respawned.
|
||||
(respawn? #f)))))
|
||||
|
||||
(define (device-mapping-service target command)
|
||||
(define (device-mapping-service target open close)
|
||||
"Return a service that maps device @var{target}, a string such as
|
||||
@code{\"home\"} (meaning @code{/dev/mapper/home}), by executing @var{command},
|
||||
a gexp."
|
||||
@code{\"home\"} (meaning @code{/dev/mapper/home}). Evaluate @var{open}, a
|
||||
gexp, to open it, and evaluate @var{close} to close it."
|
||||
(with-monad %store-monad
|
||||
(return (service
|
||||
(provision (list (symbol-append 'device-mapping-
|
||||
(string->symbol target))))
|
||||
(requirement '(udev))
|
||||
(documentation "Map a device node using Linux's device mapper.")
|
||||
(start #~(lambda ()
|
||||
#$command))
|
||||
(stop #~(const #f))
|
||||
(start #~(lambda () #$open))
|
||||
(stop #~(lambda _ (not #$close)))
|
||||
(respawn? #f)))))
|
||||
|
||||
(define %base-services
|
||||
|
|
|
@ -160,13 +160,24 @@ file."
|
|||
;;; Services.
|
||||
;;;
|
||||
|
||||
(define (luks-device-mapping source target)
|
||||
(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)))
|
||||
|
||||
(define (other-file-system-services os)
|
||||
"Return file system services for the file systems of OS that are not marked
|
||||
as 'needed-for-boot'."
|
||||
|
@ -207,11 +218,14 @@ as 'needed-for-boot'."
|
|||
"Return the list of device-mapping services for OS as a monadic list."
|
||||
(sequence %store-monad
|
||||
(map (lambda (md)
|
||||
(let ((source (mapped-device-source md))
|
||||
(let* ((source (mapped-device-source md))
|
||||
(target (mapped-device-target md))
|
||||
(command (mapped-device-command md)))
|
||||
(type (mapped-device-type md))
|
||||
(open (mapped-device-kind-open type))
|
||||
(close (mapped-device-kind-close type)))
|
||||
(device-mapping-service target
|
||||
(command source target))))
|
||||
(open source target)
|
||||
(close source target))))
|
||||
(operating-system-mapped-devices os))))
|
||||
|
||||
(define (essential-services os)
|
||||
|
|
|
@ -17,6 +17,7 @@
|
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gnu system file-systems)
|
||||
#:use-module (guix gexp)
|
||||
#:use-module (guix records)
|
||||
#:export (<file-system>
|
||||
file-system
|
||||
|
@ -43,7 +44,12 @@
|
|||
mapped-device?
|
||||
mapped-device-source
|
||||
mapped-device-target
|
||||
mapped-device-command))
|
||||
mapped-device-type
|
||||
|
||||
mapped-device-kind
|
||||
mapped-device-kind?
|
||||
mapped-device-kind-open
|
||||
mapped-device-kind-close))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
@ -145,6 +151,13 @@
|
|||
mapped-device?
|
||||
(source mapped-device-source) ;string
|
||||
(target mapped-device-target) ;string
|
||||
(command mapped-device-command)) ;source target -> gexp
|
||||
(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)))))
|
||||
|
||||
;;; file-systems.scm ends here
|
||||
|
|
Loading…
Reference in New Issue