aboutsummaryrefslogtreecommitdiff
path: root/gnu/services/base.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services/base.scm')
-rw-r--r--gnu/services/base.scm178
1 files changed, 115 insertions, 63 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index a86e8e04c7..25143c80a6 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -43,7 +43,8 @@
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
- #:export (root-file-system-service
+ #:export (fstab-service-type
+ root-file-system-service
file-system-service
user-unmount-service
device-mapping-service
@@ -105,6 +106,48 @@
;;; 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
(dmd-service
(documentation "Take care of the root file system.")
@@ -170,70 +213,79 @@ FILE-SYSTEM."
((? file-system? 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)))
+ (if (file-system-mount? 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
;; TODO(?): Make this an extensible service that takes <file-system> objects
;; and returns a list of <dmd-service>.
- (dmd-service-type
- 'file-system
- (lambda (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)))
- (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)))))))
+ (service-type (name 'file-system)
+ (extensions
+ (list (service-extension dmd-root-service-type
+ file-system-dmd-service)
+ (service-extension fstab-service-type
+ identity)))))
(define* (file-system-service file-system)
"Return a service that mounts @var{file-system}, a @code{<file-system>}
@@ -367,7 +419,7 @@ services corresponding to FILE-SYSTEMS.
All the services that spawn processes must depend on this one so that they are
stopped before 'kill' is called."
(service user-processes-service-type
- (list file-systems grace-delay)))
+ (list (filter file-system-mount? file-systems) grace-delay)))
;;;
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-25 05:25:45 +0000