system: File system sources can be marked as labels or devices.
* gnu/system/file-systems.scm (<file-system>)[title]: New field. * gnu/services/base.scm (file-system-service): Add #:title parameter. In 'start' gexp, use 'canonicalize-device-spec' and honor TITLE. * gnu/system.scm (other-file-system-services, operating-system-root-file-system, operating-system-initrd-file): Adjust accordingly. * gnu/system/linux-initrd.scm (file-system->spec): Likewise. * gnu/system/vm.scm (system-disk-image): Add 'title' field for the root file system. * guix/build/linux-initrd.scm (mount-file-system): Expect the second element of SPEC to be the title. (boot-system)[root-mount-point?, root-fs-type]: Likewise. * gnu/services/dmd.scm (dmd-configuration-file): Select 'canonicalize-device-spec'.
This commit is contained in:
parent
2405858a04
commit
d4c87617e5
|
@ -89,9 +89,11 @@ This service must be the root of the service dependency graph so that its
|
||||||
(respawn? #f)))))
|
(respawn? #f)))))
|
||||||
|
|
||||||
(define* (file-system-service device target type
|
(define* (file-system-service device target type
|
||||||
#:key (check? #t) options)
|
#:key (check? #t) options (title 'any))
|
||||||
"Return a service that mounts DEVICE on TARGET as a file system TYPE with
|
"Return a service that mounts DEVICE on TARGET as a file system TYPE with
|
||||||
OPTIONS. When CHECK? is true, check the file system before mounting it."
|
OPTIONS. TITLE is a symbol specifying what kind of name DEVICE is: 'label for
|
||||||
|
a partition label, 'device for a device file name, or 'any. When CHECK? is
|
||||||
|
true, check the file system before mounting it."
|
||||||
(with-monad %store-monad
|
(with-monad %store-monad
|
||||||
(return
|
(return
|
||||||
(service
|
(service
|
||||||
|
@ -99,10 +101,11 @@ OPTIONS. When CHECK? is true, check the file system before mounting it."
|
||||||
(requirement '(root-file-system))
|
(requirement '(root-file-system))
|
||||||
(documentation "Check, mount, and unmount the given file system.")
|
(documentation "Check, mount, and unmount the given file system.")
|
||||||
(start #~(lambda args
|
(start #~(lambda args
|
||||||
|
(let ((device (canonicalize-device-spec #$device '#$title)))
|
||||||
#$(if check?
|
#$(if check?
|
||||||
#~(check-file-system #$device #$type)
|
#~(check-file-system device #$type)
|
||||||
#~#t)
|
#~#t)
|
||||||
(mount #$device #$target #$type 0 #$options)
|
(mount device #$target #$type 0 #$options))
|
||||||
#t))
|
#t))
|
||||||
(stop #~(lambda args
|
(stop #~(lambda args
|
||||||
;; Normally there are no processes left at this point, so
|
;; Normally there are no processes left at this point, so
|
||||||
|
|
|
@ -50,7 +50,7 @@
|
||||||
(use-modules (ice-9 ftw)
|
(use-modules (ice-9 ftw)
|
||||||
(guix build syscalls)
|
(guix build syscalls)
|
||||||
((guix build linux-initrd)
|
((guix build linux-initrd)
|
||||||
#:select (check-file-system)))
|
#:select (check-file-system canonicalize-device-spec)))
|
||||||
|
|
||||||
(register-services
|
(register-services
|
||||||
#$@(map (lambda (service)
|
#$@(map (lambda (service)
|
||||||
|
|
|
@ -182,8 +182,10 @@ as 'needed-for-boot'."
|
||||||
|
|
||||||
(sequence %store-monad
|
(sequence %store-monad
|
||||||
(map (match-lambda
|
(map (match-lambda
|
||||||
(($ <file-system> device target type flags opts #f check?)
|
(($ <file-system> device title target type flags opts
|
||||||
|
#f check?)
|
||||||
(file-system-service device target type
|
(file-system-service device target type
|
||||||
|
#:title title
|
||||||
#:check? check?
|
#:check? check?
|
||||||
#:options opts)))
|
#:options opts)))
|
||||||
file-systems)))
|
file-systems)))
|
||||||
|
@ -449,7 +451,7 @@ we're running in the final root."
|
||||||
(define (operating-system-root-file-system os)
|
(define (operating-system-root-file-system os)
|
||||||
"Return the root file system of OS."
|
"Return the root file system of OS."
|
||||||
(find (match-lambda
|
(find (match-lambda
|
||||||
(($ <file-system> _ "/") #t)
|
(($ <file-system> _ _ "/") #t)
|
||||||
(_ #f))
|
(_ #f))
|
||||||
(operating-system-file-systems os)))
|
(operating-system-file-systems os)))
|
||||||
|
|
||||||
|
@ -457,9 +459,10 @@ we're running in the final root."
|
||||||
"Return a gexp denoting the initrd file of OS."
|
"Return a gexp denoting the initrd file of OS."
|
||||||
(define boot-file-systems
|
(define boot-file-systems
|
||||||
(filter (match-lambda
|
(filter (match-lambda
|
||||||
(($ <file-system> device "/")
|
(($ <file-system> device title "/")
|
||||||
#t)
|
#t)
|
||||||
(($ <file-system> device mount-point type flags options boot?)
|
(($ <file-system> device title mount-point type flags
|
||||||
|
options boot?)
|
||||||
boot?))
|
boot?))
|
||||||
(operating-system-file-systems os)))
|
(operating-system-file-systems os)))
|
||||||
|
|
||||||
|
|
|
@ -22,6 +22,7 @@
|
||||||
file-system
|
file-system
|
||||||
file-system?
|
file-system?
|
||||||
file-system-device
|
file-system-device
|
||||||
|
file-system-title
|
||||||
file-system-mount-point
|
file-system-mount-point
|
||||||
file-system-type
|
file-system-type
|
||||||
file-system-needed-for-boot?
|
file-system-needed-for-boot?
|
||||||
|
@ -42,6 +43,8 @@
|
||||||
make-file-system
|
make-file-system
|
||||||
file-system?
|
file-system?
|
||||||
(device file-system-device) ; string
|
(device file-system-device) ; string
|
||||||
|
(title file-system-title ; 'device | 'label | 'uuid
|
||||||
|
(default 'device))
|
||||||
(mount-point file-system-mount-point) ; string
|
(mount-point file-system-mount-point) ; string
|
||||||
(type file-system-type) ; string
|
(type file-system-type) ; string
|
||||||
(flags file-system-flags ; list of symbols
|
(flags file-system-flags ; list of symbols
|
||||||
|
|
|
@ -198,8 +198,8 @@ a list of Guile module names to be embedded in the initrd."
|
||||||
"Return a list corresponding to file-system FS that can be passed to the
|
"Return a list corresponding to file-system FS that can be passed to the
|
||||||
initrd code."
|
initrd code."
|
||||||
(match fs
|
(match fs
|
||||||
(($ <file-system> device mount-point type flags options _ check?)
|
(($ <file-system> device title mount-point type flags options _ check?)
|
||||||
(list device mount-point type flags options check?))))
|
(list device title mount-point type flags options check?))))
|
||||||
|
|
||||||
(define* (qemu-initrd file-systems
|
(define* (qemu-initrd file-systems
|
||||||
#:key
|
#:key
|
||||||
|
|
|
@ -290,6 +290,7 @@ to USB sticks meant to be read-only."
|
||||||
(file-systems (cons (file-system
|
(file-systems (cons (file-system
|
||||||
(mount-point "/")
|
(mount-point "/")
|
||||||
(device root-label)
|
(device root-label)
|
||||||
|
(title 'label)
|
||||||
(type file-system-type))
|
(type file-system-type))
|
||||||
file-systems-to-keep)))))
|
file-systems-to-keep)))))
|
||||||
|
|
||||||
|
|
|
@ -37,6 +37,7 @@
|
||||||
disk-partitions
|
disk-partitions
|
||||||
partition-label-predicate
|
partition-label-predicate
|
||||||
find-partition-by-label
|
find-partition-by-label
|
||||||
|
canonicalize-device-spec
|
||||||
|
|
||||||
check-file-system
|
check-file-system
|
||||||
mount-file-system
|
mount-file-system
|
||||||
|
@ -485,7 +486,7 @@ UNIONFS."
|
||||||
"Mount the file system described by SPEC under ROOT. SPEC must have the
|
"Mount the file system described by SPEC under ROOT. SPEC must have the
|
||||||
form:
|
form:
|
||||||
|
|
||||||
(DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
|
(DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
|
||||||
|
|
||||||
DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
|
DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
|
||||||
FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
|
FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
|
||||||
|
@ -500,8 +501,8 @@ run a file system check."
|
||||||
0)))
|
0)))
|
||||||
|
|
||||||
(match spec
|
(match spec
|
||||||
((source mount-point type (flags ...) options check?)
|
((source title mount-point type (flags ...) options check?)
|
||||||
(let ((source (canonicalize-device-spec source))
|
(let ((source (canonicalize-device-spec source title))
|
||||||
(mount-point (string-append root "/" mount-point)))
|
(mount-point (string-append root "/" mount-point)))
|
||||||
(when check?
|
(when check?
|
||||||
(check-file-system source type))
|
(check-file-system source type))
|
||||||
|
@ -596,12 +597,12 @@ to it are lost."
|
||||||
|
|
||||||
(define root-mount-point?
|
(define root-mount-point?
|
||||||
(match-lambda
|
(match-lambda
|
||||||
((device "/" _ ...) #t)
|
((device _ "/" _ ...) #t)
|
||||||
(_ #f)))
|
(_ #f)))
|
||||||
|
|
||||||
(define root-fs-type
|
(define root-fs-type
|
||||||
(or (any (match-lambda
|
(or (any (match-lambda
|
||||||
((device "/" type _ ...) type)
|
((device _ "/" type _ ...) type)
|
||||||
(_ #f))
|
(_ #f))
|
||||||
mounts)
|
mounts)
|
||||||
"ext4"))
|
"ext4"))
|
||||||
|
|
Loading…
Reference in New Issue