services: Add 'fstab-service-type'.
* gnu/services/base.scm (file-system->fstab-entry) (file-systems->fstab): New procedures. (fstab-service-type): New variable. * gnu/services/base.scm (file-system-dmd-service): New procedure, taken from... (file-system-service-type): ... here. * gnu/system.scm (essential-services): Add FSTAB-SERVICE-TYPE instance.
This commit is contained in:
Ludovic Courtès
parent
12d38e8d43
commit
e43e84ba7a
|
|
@ -43,7 +43,8 @@
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
#:export (root-file-system-service
|
#:export (fstab-service-type
|
||||||
|
root-file-system-service
|
||||||
file-system-service
|
file-system-service
|
||||||
user-unmount-service
|
user-unmount-service
|
||||||
device-mapping-service
|
device-mapping-service
|
||||||
|
|
@ -105,6 +106,48 @@
|
||||||
;;; File systems.
|
;;; File systems.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
|
(define (file-system->fstab-entry file-system)
|
||||||
|
"Return a @file{/etc/fstab} entry for @var{file-system}."
|
||||||
|
(string-append (case (file-system-title file-system)
|
||||||
|
((label)
|
||||||
|
(string-append "LABEL=" (file-system-device file-system)))
|
||||||
|
((uuid)
|
||||||
|
(string-append
|
||||||
|
"UUID="
|
||||||
|
(uuid->string (file-system-device file-system))))
|
||||||
|
(else
|
||||||
|
(file-system-device file-system)))
|
||||||
|
"\t"
|
||||||
|
(file-system-mount-point file-system) "\t"
|
||||||
|
(file-system-type file-system) "\t"
|
||||||
|
(or (file-system-options file-system) "defaults") "\t"
|
||||||
|
|
||||||
|
;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
|
||||||
|
;; don't have anything sensible to put in there.
|
||||||
|
))
|
||||||
|
|
||||||
|
(define (file-systems->fstab file-systems)
|
||||||
|
"Return a @file{/etc} entry for an @file{fstab} describing
|
||||||
|
@var{file-systems}."
|
||||||
|
`(("fstab" ,(plain-file "fstab"
|
||||||
|
(string-append
|
||||||
|
"\
|
||||||
|
# This file was generated from your GuixSD configuration. Any changes
|
||||||
|
# will be lost upon reboot or reconfiguration.\n\n"
|
||||||
|
(string-join (map file-system->fstab-entry
|
||||||
|
file-systems)
|
||||||
|
"\n")
|
||||||
|
"\n")))))
|
||||||
|
|
||||||
|
(define fstab-service-type
|
||||||
|
;; The /etc/fstab service.
|
||||||
|
(service-type (name 'fstab)
|
||||||
|
(extensions
|
||||||
|
(list (service-extension etc-service-type
|
||||||
|
file-systems->fstab)))
|
||||||
|
(compose identity)
|
||||||
|
(extend append)))
|
||||||
|
|
||||||
(define %root-file-system-dmd-service
|
(define %root-file-system-dmd-service
|
||||||
(dmd-service
|
(dmd-service
|
||||||
(documentation "Take care of the root file system.")
|
(documentation "Take care of the root file system.")
|
||||||
|
|
@ -170,70 +213,76 @@ FILE-SYSTEM."
|
||||||
((? file-system? fs)
|
((? file-system? fs)
|
||||||
(file-system->dmd-service-name fs))))
|
(file-system->dmd-service-name fs))))
|
||||||
|
|
||||||
|
(define (file-system-dmd-service file-system)
|
||||||
|
"Return a list containing the dmd service for @var{file-system}."
|
||||||
|
(let ((target (file-system-mount-point file-system))
|
||||||
|
(device (file-system-device file-system))
|
||||||
|
(type (file-system-type file-system))
|
||||||
|
(title (file-system-title file-system))
|
||||||
|
(check? (file-system-check? file-system))
|
||||||
|
(create? (file-system-create-mount-point? file-system))
|
||||||
|
(dependencies (file-system-dependencies file-system)))
|
||||||
|
(list (dmd-service
|
||||||
|
(provision (list (file-system->dmd-service-name file-system)))
|
||||||
|
(requirement `(root-file-system
|
||||||
|
,@(map dependency->dmd-service-name dependencies)))
|
||||||
|
(documentation "Check, mount, and unmount the given file system.")
|
||||||
|
(start #~(lambda args
|
||||||
|
;; FIXME: Use or factorize with 'mount-file-system'.
|
||||||
|
(let ((device (canonicalize-device-spec #$device '#$title))
|
||||||
|
(flags #$(mount-flags->bit-mask
|
||||||
|
(file-system-flags file-system))))
|
||||||
|
#$(if create?
|
||||||
|
#~(mkdir-p #$target)
|
||||||
|
#~#t)
|
||||||
|
#$(if check?
|
||||||
|
#~(begin
|
||||||
|
;; Make sure fsck.ext2 & co. can be found.
|
||||||
|
(setenv "PATH"
|
||||||
|
(string-append
|
||||||
|
#$e2fsprogs "/sbin:"
|
||||||
|
"/run/current-system/profile/sbin:"
|
||||||
|
(getenv "PATH")))
|
||||||
|
(check-file-system device #$type))
|
||||||
|
#~#t)
|
||||||
|
|
||||||
|
(mount device #$target #$type flags
|
||||||
|
#$(file-system-options file-system))
|
||||||
|
|
||||||
|
;; For read-only bind mounts, an extra remount is needed,
|
||||||
|
;; as per <http://lwn.net/Articles/281157/>, which still
|
||||||
|
;; applies to Linux 4.0.
|
||||||
|
(when (and (= MS_BIND (logand flags MS_BIND))
|
||||||
|
(= MS_RDONLY (logand flags MS_RDONLY)))
|
||||||
|
(mount device #$target #$type
|
||||||
|
(logior MS_BIND MS_REMOUNT MS_RDONLY))))
|
||||||
|
#t))
|
||||||
|
(stop #~(lambda args
|
||||||
|
;; Normally there are no processes left at this point, so
|
||||||
|
;; TARGET can be safely unmounted.
|
||||||
|
|
||||||
|
;; Make sure PID 1 doesn't keep TARGET busy.
|
||||||
|
(chdir "/")
|
||||||
|
|
||||||
|
(umount #$target)
|
||||||
|
#f))
|
||||||
|
|
||||||
|
;; We need an additional module.
|
||||||
|
(modules `(((gnu build file-systems)
|
||||||
|
#:select (check-file-system canonicalize-device-spec))
|
||||||
|
,@%default-modules))
|
||||||
|
(imported-modules `((gnu build file-systems)
|
||||||
|
,@%default-imported-modules))))))
|
||||||
|
|
||||||
(define file-system-service-type
|
(define file-system-service-type
|
||||||
;; TODO(?): Make this an extensible service that takes <file-system> objects
|
;; TODO(?): Make this an extensible service that takes <file-system> objects
|
||||||
;; and returns a list of <dmd-service>.
|
;; and returns a list of <dmd-service>.
|
||||||
(dmd-service-type
|
(service-type (name 'file-system)
|
||||||
'file-system
|
(extensions
|
||||||
(lambda (file-system)
|
(list (service-extension dmd-root-service-type
|
||||||
(let ((target (file-system-mount-point file-system))
|
file-system-dmd-service)
|
||||||
(device (file-system-device file-system))
|
(service-extension fstab-service-type
|
||||||
(type (file-system-type file-system))
|
identity)))))
|
||||||
(title (file-system-title file-system))
|
|
||||||
(check? (file-system-check? file-system))
|
|
||||||
(create? (file-system-create-mount-point? file-system))
|
|
||||||
(dependencies (file-system-dependencies file-system)))
|
|
||||||
(dmd-service
|
|
||||||
(provision (list (file-system->dmd-service-name file-system)))
|
|
||||||
(requirement `(root-file-system
|
|
||||||
,@(map dependency->dmd-service-name dependencies)))
|
|
||||||
(documentation "Check, mount, and unmount the given file system.")
|
|
||||||
(start #~(lambda args
|
|
||||||
;; FIXME: Use or factorize with 'mount-file-system'.
|
|
||||||
(let ((device (canonicalize-device-spec #$device '#$title))
|
|
||||||
(flags #$(mount-flags->bit-mask
|
|
||||||
(file-system-flags file-system))))
|
|
||||||
#$(if create?
|
|
||||||
#~(mkdir-p #$target)
|
|
||||||
#~#t)
|
|
||||||
#$(if check?
|
|
||||||
#~(begin
|
|
||||||
;; Make sure fsck.ext2 & co. can be found.
|
|
||||||
(setenv "PATH"
|
|
||||||
(string-append
|
|
||||||
#$e2fsprogs "/sbin:"
|
|
||||||
"/run/current-system/profile/sbin:"
|
|
||||||
(getenv "PATH")))
|
|
||||||
(check-file-system device #$type))
|
|
||||||
#~#t)
|
|
||||||
|
|
||||||
(mount device #$target #$type flags
|
|
||||||
#$(file-system-options file-system))
|
|
||||||
|
|
||||||
;; For read-only bind mounts, an extra remount is needed,
|
|
||||||
;; as per <http://lwn.net/Articles/281157/>, which still
|
|
||||||
;; applies to Linux 4.0.
|
|
||||||
(when (and (= MS_BIND (logand flags MS_BIND))
|
|
||||||
(= MS_RDONLY (logand flags MS_RDONLY)))
|
|
||||||
(mount device #$target #$type
|
|
||||||
(logior MS_BIND MS_REMOUNT MS_RDONLY))))
|
|
||||||
#t))
|
|
||||||
(stop #~(lambda args
|
|
||||||
;; Normally there are no processes left at this point, so
|
|
||||||
;; TARGET can be safely unmounted.
|
|
||||||
|
|
||||||
;; Make sure PID 1 doesn't keep TARGET busy.
|
|
||||||
(chdir "/")
|
|
||||||
|
|
||||||
(umount #$target)
|
|
||||||
#f))
|
|
||||||
|
|
||||||
;; We need an additional module.
|
|
||||||
(modules `(((gnu build file-systems)
|
|
||||||
#:select (check-file-system canonicalize-device-spec))
|
|
||||||
,@%default-modules))
|
|
||||||
(imported-modules `((gnu build file-systems)
|
|
||||||
,@%default-imported-modules)))))))
|
|
||||||
|
|
||||||
(define* (file-system-service file-system)
|
(define* (file-system-service file-system)
|
||||||
"Return a service that mounts @var{file-system}, a @code{<file-system>}
|
"Return a service that mounts @var{file-system}, a @code{<file-system>}
|
||||||
|
|
|
||||||
|
|
@ -299,6 +299,7 @@ a container or that of a \"bare metal\" system."
|
||||||
(operating-system-groups os))
|
(operating-system-groups os))
|
||||||
(operating-system-skeletons os))
|
(operating-system-skeletons os))
|
||||||
(operating-system-etc-service os)
|
(operating-system-etc-service os)
|
||||||
|
(service fstab-service-type '())
|
||||||
(session-environment-service
|
(session-environment-service
|
||||||
(operating-system-environment-variables os))
|
(operating-system-environment-variables os))
|
||||||
host-name procs root-fs unmount
|
host-name procs root-fs unmount
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue