system: Honor the 'dependencies' field of file systems.
This allows mapped devices listed in 'dependencies' to be properly taken into account. Reported by Andreas Enge <andreas@enge.fr>. * gnu/system.scm (mapped-device-user): Check whether DEVICE is a member of the 'dependencies' of FS. * tests/system.scm (%luks-device, %os-with-mapped-device): New variables. ("operating-system-user-mapped-devices") ("operating-system-boot-mapped-devices") ("operating-system-boot-mapped-devices, implicit dependency"): New tests.
This commit is contained in:
parent
0b07350675
commit
2bdd7ac17c
|
@ -81,6 +81,8 @@
|
||||||
operating-system-mapped-devices
|
operating-system-mapped-devices
|
||||||
operating-system-file-systems
|
operating-system-file-systems
|
||||||
operating-system-store-file-system
|
operating-system-store-file-system
|
||||||
|
operating-system-user-mapped-devices
|
||||||
|
operating-system-boot-mapped-devices
|
||||||
operating-system-activation-script
|
operating-system-activation-script
|
||||||
operating-system-user-accounts
|
operating-system-user-accounts
|
||||||
operating-system-shepherd-service-names
|
operating-system-shepherd-service-names
|
||||||
|
@ -208,8 +210,9 @@ as 'needed-for-boot'."
|
||||||
"Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
|
"Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
|
||||||
(let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
|
(let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
|
||||||
(find (lambda (fs)
|
(find (lambda (fs)
|
||||||
|
(or (member device (file-system-dependencies fs))
|
||||||
(and (eq? 'device (file-system-title fs))
|
(and (eq? 'device (file-system-title fs))
|
||||||
(string=? (file-system-device fs) target)))
|
(string=? (file-system-device fs) target))))
|
||||||
file-systems)))
|
file-systems)))
|
||||||
|
|
||||||
(define (operating-system-user-mapped-devices os)
|
(define (operating-system-user-mapped-devices os)
|
||||||
|
|
|
@ -41,6 +41,25 @@
|
||||||
|
|
||||||
(users %base-user-accounts)))
|
(users %base-user-accounts)))
|
||||||
|
|
||||||
|
(define %luks-device
|
||||||
|
(mapped-device
|
||||||
|
(source "/dev/foo") (target "my-luks-device")
|
||||||
|
(type luks-device-mapping)))
|
||||||
|
|
||||||
|
(define %os-with-mapped-device
|
||||||
|
(operating-system
|
||||||
|
(host-name "komputilo")
|
||||||
|
(timezone "Europe/Berlin")
|
||||||
|
(locale "en_US.utf8")
|
||||||
|
(bootloader (grub-configuration (device "/dev/sdX")))
|
||||||
|
(mapped-devices (list %luks-device))
|
||||||
|
(file-systems (cons (file-system
|
||||||
|
(inherit %root-fs)
|
||||||
|
(dependencies (list %luks-device)))
|
||||||
|
%base-file-systems))
|
||||||
|
(users %base-user-accounts)))
|
||||||
|
|
||||||
|
|
||||||
(test-begin "system")
|
(test-begin "system")
|
||||||
|
|
||||||
(test-assert "operating-system-store-file-system"
|
(test-assert "operating-system-store-file-system"
|
||||||
|
@ -71,4 +90,28 @@
|
||||||
%base-file-systems)))))
|
%base-file-systems)))))
|
||||||
(eq? gnu (operating-system-store-file-system os))))
|
(eq? gnu (operating-system-store-file-system os))))
|
||||||
|
|
||||||
|
(test-equal "operating-system-user-mapped-devices"
|
||||||
|
'()
|
||||||
|
(operating-system-user-mapped-devices %os-with-mapped-device))
|
||||||
|
|
||||||
|
(test-equal "operating-system-boot-mapped-devices"
|
||||||
|
(list %luks-device)
|
||||||
|
(operating-system-boot-mapped-devices %os-with-mapped-device))
|
||||||
|
|
||||||
|
(test-equal "operating-system-boot-mapped-devices, implicit dependency"
|
||||||
|
(list %luks-device)
|
||||||
|
|
||||||
|
;; Here we expect the implicit dependency between "/" and
|
||||||
|
;; "/dev/mapper/my-luks-device" to be found, in spite of the lack of a
|
||||||
|
;; 'dependencies' field in the root file system.
|
||||||
|
(operating-system-boot-mapped-devices
|
||||||
|
(operating-system
|
||||||
|
(inherit %os-with-mapped-device)
|
||||||
|
(file-systems (cons (file-system
|
||||||
|
(device "/dev/mapper/my-luks-device")
|
||||||
|
(title 'device)
|
||||||
|
(mount-point "/")
|
||||||
|
(type "ext4"))
|
||||||
|
%base-file-systems)))))
|
||||||
|
|
||||||
(test-end)
|
(test-end)
|
||||||
|
|
Loading…
Reference in New Issue