Skip to content
Snippets Groups Projects
Commit d4c87617 authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

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'.
parent 2405858a
No related branches found
No related tags found
No related merge requests found
...@@ -89,9 +89,11 @@ (define (root-file-system-service) ...@@ -89,9 +89,11 @@ (define (root-file-system-service)
(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 @@ (define* (file-system-service device target type ...@@ -99,10 +101,11 @@ (define* (file-system-service device target type
(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
#$(if check? (let ((device (canonicalize-device-spec #$device '#$title)))
#~(check-file-system #$device #$type) #$(if check?
#~#t) #~(check-file-system device #$type)
(mount #$device #$target #$type 0 #$options) #~#t)
(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 @@ (define config ...@@ -50,7 +50,7 @@ (define config
(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 @@ (define file-systems ...@@ -182,8 +182,10 @@ (define file-systems
(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 @@ (define (operating-system-boot-script os) ...@@ -449,7 +451,7 @@ (define (operating-system-boot-script os)
(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 @@ (define (operating-system-initrd-file os) ...@@ -457,9 +459,10 @@ (define (operating-system-initrd-file os)
"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 @@ (define-module (gnu system file-systems) ...@@ -22,6 +22,7 @@ (define-module (gnu system file-systems)
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 @@ (define-record-type* <file-system> file-system ...@@ -42,6 +43,8 @@ (define-record-type* <file-system> file-system
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 @@ (define (file-system->spec fs) ...@@ -198,8 +198,8 @@ (define (file-system->spec fs)
"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 @@ (define file-systems-to-keep ...@@ -290,6 +290,7 @@ (define file-systems-to-keep
(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 @@ (define-module (guix build linux-initrd) ...@@ -37,6 +37,7 @@ (define-module (guix build linux-initrd)
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 @@ (define* (mount-file-system spec #:key (root "/root")) ...@@ -485,7 +486,7 @@ (define* (mount-file-system spec #:key (root "/root"))
"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 @@ (define flags->bit-mask ...@@ -500,8 +501,8 @@ (define flags->bit-mask
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 @@ (define (resolve file) ...@@ -596,12 +597,12 @@ (define (resolve file)
(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"))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment