~ruther/guix-local

be21979d85304fedd5c0fb970ffc337d220eda7a — Ludovic Courtès 10 years ago e43e84b
file-systems: Add a 'mount?' field.

Fixes <http://bugs.gnu.org/22176>.
Reported by Florian Paul Schmidt <mista.tapas@gmx.net>.

* gnu/system/file-systems.scm (<file-system>)[mount?]: New field.
(file-system->spec): Adjust accordingly.
* gnu/services/base.scm (file-system-dmd-service): Return the empty list
when FILE-SYSTEM has 'mount?' set to false.
(user-processes-service): Select the subset of FILE-SYSTEMS that matches
'file-system-mount?'.
* doc/guix.texi (File Systems): Document it.
3 files changed, 65 insertions(+), 53 deletions(-)

M doc/guix.texi
M gnu/services/base.scm
M gnu/system/file-systems.scm
M doc/guix.texi => doc/guix.texi +6 -0
@@ 5936,6 5936,12 @@ bits), and @code{no-exec} (disallow program execution.)
@item @code{options} (default: @code{#f})
This is either @code{#f}, or a string denoting mount options.

@item @code{mount?} (default: @code{#t})
This value indicates whether to automatically mount the file system when
the system is brought up.  When set to @code{#f}, the file system gets
an entry in @file{/etc/fstab} (read by the @command{mount} command) but
is not automatically mounted.

@item @code{needed-for-boot?} (default: @code{#f})
This Boolean value indicates whether the file system is needed when
booting.  If that is true, then the file system is mounted when the

M gnu/services/base.scm => gnu/services/base.scm +55 -52
@@ 222,57 222,60 @@ 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))))))
    (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


@@ 416,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)))


;;;

M gnu/system/file-systems.scm => gnu/system/file-systems.scm +4 -1
@@ 35,6 35,7 @@
            file-system-needed-for-boot?
            file-system-flags
            file-system-options
            file-system-mount?
            file-system-check?
            file-system-create-mount-point?
            file-system-dependencies


@@ 93,6 94,8 @@
                    (default '()))
  (options          file-system-options           ; string or #f
                    (default #f))
  (mount?           file-system-mount?            ; Boolean
                    (default #t))
  (needed-for-boot? %file-system-needed-for-boot? ; Boolean
                    (default #f))
  (check?           file-system-check?            ; Boolean


@@ 112,7 115,7 @@ file system."
  "Return a list corresponding to file-system FS that can be passed to the
initrd code."
  (match fs
    (($ <file-system> device title mount-point type flags options _ check?)
    (($ <file-system> device title mount-point type flags options _ _ check?)
     (list device title mount-point type flags options check?))))

(define %uuid-rx