services: Add vfs-mapping-service-type.

* gnu/services/linux.scm (vfs-mapping-service-type, vfs-mapping-configuration,
vfs-mapping-binding): New variables.
* doc/guix.texi: (Vfs Mapping Service): New subsubsection under "Linux Services".

Change-Id: I7ebd48afb809ded9fa6fe9eb80c618accb856716
Signed-off-by: Maxim Cournoyer <maxim@guixotic.coop>

2 files changed, 305 insertions, 2 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 500f6e78e9..98b388886b 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -142,6 +142,7 @@ Copyright @copyright{} 2025 Sergio Pastor Pérez@*
 Copyright @copyright{} 2024 Evgeny Pisemsky@*
 Copyright @copyright{} 2025 jgart@*
 Copyright @copyright{} 2025 Artur Wroblewski@*
+Copyright @copyright{} 2025 Edouard Klein@*
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -43401,6 +43402,148 @@ this value will override the @code{ttl} when used for narinfo requests.
 @node Linux Services
 @subsection Linux Services
 
+@subsubheading VFS Mapping Service
+@cindex VFS mapping
+@cindex Virtual File System mapping
+@cindex bind mounts, service
+@cindex overlay mounts, service
+
+The VFS (Virtual File System) Mapping service allows you to bind a file
+name under a different name in the global namespace.  For example, this
+is used by the Shared Cache Service (@pxref{Guix Services}) to bind the
+@samp{root} user's cache over another user's cache.  Another use case
+may be to expose game data from the store over your home directory, and
+apply modifications there.
+
+The service has three @emph{policies} to choose from with respect to
+access rights on the bound over path:
+
+@table @code
+@item 'bind
+Use a bind mount; the ownership and file
+permissions of the destination are the same as the source.
+
+@item 'translate
+Use bindfs to make the destination appear as owned by the target user
+and group.  Writes will be propagated back to the source as if made by
+the original owner.
+
+@item 'overlay
+Use an overlay to make the destination appear as owned by the target
+user and group. Writes will not appear in the source, but will be stored
+in a target-user-owned @samp{-overlay} suffixed directory near the
+destination.
+@end table
+
+Here is an example configuration that exposes the default data directory
+of @command{tuxpaint} under the home directory of @code{alice}.  Any
+modification made by Alice to the brushes or stamps will not propagate
+back to the store (which is read-only anyway).
+
+@lisp
+(operating-system
+  ;; @dots{}
+  (services
+   (cons*
+    (service vfs-mapping-service-type
+             (vfs-mapping-configuration
+              (bindings (list (vfs-mapping
+                               (source      #~(string-append #$tuxpaint
+                                                             "/share/tuxpaint"))
+                               (destination "/home/alice/.tuxpaint")
+                               (user        "alice")
+                               (policy      'overlay)
+                               (name        "alice-tuxpaint-overlay"))))))
+    %desktop-services)))
+@end lisp
+
+The service can also be extended by providing a list of
+@code{vfs-mapping}, allowing for easier splitting of configuration.
+
+@lisp
+(operating-system
+  ;; @dots{}
+  (services
+   (cons*
+    (simple-service 'bob-too-wants-to-hack-on-tuxpaint
+                    vfs-mapping-service-type
+                    (list (vfs-mapping
+                           (source      #~(string-append #$tuxpaint "/share/tuxpaint"))
+                           (destination "/home/bob/.tuxpaint")
+                           (user        "bob")
+                           (policy      'overlay)
+                           (name        "bob-tuxpaint-overlay"))))
+    %desktop-services)))
+@end lisp
+
+The @code{source} file name must exist for the service to start.  The
+@code{destination} directory will be created if it does not exist.
+
+@defvar vfs-mapping-service-type
+Service type for binding a directory in multiple places on the file
+system.
+
+The access rights are either the same in source and destination
+(@code{'bind}), or writes are translated back to the sources as if made
+by the destination's owner (@code{'translate}), or kept in an overlay
+directory near the destination (@code{'overlay}).  The service's value
+must be a @code{vfs-mapping-configuration} object.
+@end defvar
+
+@deftp {Data Type} vfs-mapping-configuration
+Data type representing the configuration of the vfs-mapping service.
+
+@table @asis
+@item @code{bindfs} (default: @code{#~(string-append #$bindfs "/bin/bindfs")})
+The @command{bindfs} command to use for mounting.
+
+@item @code{fusermount} (default: @code{#~(string-append #$fuse-2 "/bin/fusermount")})
+The @command{fusermount} command to use.
+
+@item @code{umount} (default: @code{#~(string-append #$util-linux+udev "/bin/umount")})
+The @command{umount} command to use.
+
+@item @code{bindings} (default: @code{'()})
+A list of @code{vfs-mapping} records.
+
+@end table
+@end deftp
+
+@deftp {Data Type} vfs-mapping
+Data type representing the configuration for a single shared directory.
+
+@table @asis
+@item @code{source}
+The source file name to be shared.
+
+@item @code{destination}
+The destination at which the contents of @code{source} will be exposed.
+
+@item @code{policy} (default: @code{'translate})
+Either @code{'bind} (same ownership and access rights for @code{source}
+and @code{destination}), @code{'translate} (read-write, with writes
+translated as if made by @code{source}'s owner), or @code{'overlay}
+(read-only with @code{user}-owned writable overlay).
+
+@item @code{user} (default: @code{#f})
+The user that will own the @code{destination} directory, and appear to
+own its content.  It must be kept at its default @code{#f} value when
+using the @code{'bind} policy.
+
+@item @code{group} (default: @code{"users"})
+The group that will own the @code{destination} directory, and appear to
+own its content.
+
+@item @code{name} (default: @code{"<src>-[<policy>]-><dst>"})
+The name of the shepherd service to mount and unmount the binding.
+
+@item @code{requirement} (default: @code{'(file-systems user-homes)})
+The list of services that Shepherd ought to provision before trying to
+mount.
+
+@end table
+@end deftp
+
 @cindex oom
 @cindex out of memory killer
 @cindex earlyoom
diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm
index d7aee1b82e..80c35717a9 100644
--- a/gnu/services/linux.scm
+++ b/gnu/services/linux.scm
@@ -7,6 +7,7 @@
 ;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
 ;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
 ;;; Copyright © 2023 Felix Lechner <felix.lechner@lease-up.com>
+;;; Copyright © 2025 Edouard Klein <edk@beaver-labs.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -36,6 +37,7 @@
   #:use-module (gnu services configuration)
   #:use-module (gnu services shepherd)
   #:use-module (gnu packages linux)
+  #:use-module (gnu packages file-systems)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -101,7 +103,11 @@
             zram-device-configuration-compression-algorithm
             zram-device-configuration-memory-limit
             zram-device-configuration-priority
-            zram-device-service-type))
+            zram-device-service-type
+
+            vfs-mapping-service-type
+            vfs-mapping-configuration
+            vfs-mapping))
 
 
 ;;;
@@ -547,7 +553,6 @@ the Linux @code{cachefiles} module.")
 ;;;
 ;;; Zram device
 ;;;
-
 (define-record-type* <zram-device-configuration>
   zram-device-configuration make-zram-device-configuration
   zram-device-configuration?
@@ -628,3 +633,158 @@ placed in a udev rules file."
             (service-extension udev-service-type
                                (compose list zram-device-udev-rule))))
     (description "Creates a zram swap device.")))
+
+
+;;;
+;;; VFS Mapping.
+;;;
+
+(define-record-type* <vfs-mapping>
+  vfs-mapping make-vfs-mapping
+  vfs-mapping?
+  (source        vfs-mapping-source)
+  (destination   vfs-mapping-destination)
+  (policy        vfs-mapping-policy
+                 (default 'translate))
+  (user          vfs-mapping-user
+                 (default #f))
+  (group         vfs-mapping-group
+                 (default "users"))
+  (name          vfs-mapping-name
+                 (default (string-append
+                           (vfs-mapping-source      this-record) "-["
+                           (vfs-mapping-policy      this-record) "]->"
+                           (vfs-mapping-destination this-record)))
+                 (thunked))
+  (requirement   vfs-mapping-requirement
+                 (default '(file-systems user-homes))))
+
+(define (vfs-mapping-policy? x)
+  (and (symbol? x)
+       (or (memq x '(bind translate overlay)))))
+
+(define (path-like? x)
+  (or (string?    x)
+      (file-like? x)
+      (gexp?      x)))
+
+(define (valid-vfs-mapping? x)
+  ;; User must be set iff we are going to use it
+  (and (vfs-mapping? x)
+       (path-like?       (vfs-mapping-source      x))
+       (path-like?       (vfs-mapping-destination x))
+       (string?          (vfs-mapping-name        x))
+       (vfs-mapping-policy? (vfs-mapping-policy   x))
+       (cond
+        ((eq? (vfs-mapping-policy x) 'bind)
+         (not (vfs-mapping-user x)))
+        (#t
+         (and (string? (vfs-mapping-user  x))
+              (string? (vfs-mapping-group x)))))))
+
+(define list-of-vfs-mapping? (list-of valid-vfs-mapping?))
+
+(define-configuration/no-serialization vfs-mapping-configuration
+  (bindfs     (gexp #~(string-append #$bindfs          "/bin/bindfs"))
+              "The bindfs command to use.")
+  (fusermount (gexp #~(string-append #$fuse-2          "/bin/fusermount"))
+              "The fusermount command to use.")
+  (umount     (gexp #~(string-append #$util-linux+udev "/bin/umount"))
+              "The umount command to use.")
+  (bindings   (list-of-vfs-mapping '())
+              "The list of bindings to mount"))
+
+(define vfs-mapping-shepherd-services
+  (match-record-lambda <vfs-mapping-configuration>
+      (fusermount bindfs umount bindings)
+    (map
+     (match-record-lambda <vfs-mapping>
+         (source destination policy user group name requirement)
+       (shepherd-service
+         ;; Each binding has its own service
+         (provision (list (string->symbol name)))
+         ;; Make sure the homes are already present
+         (requirement requirement)
+         (stop
+          #~(lambda args
+              (match (quote #$policy)
+                ('bind      (invoke #$umount          #$destination))
+                ('translate (invoke #$fusermount "-u" #$destination))
+                ('overlay   (begin
+                              ;; First the bindfs
+                              (invoke #$fusermount "-u" #$destination)
+                              ;; then the overlay
+                              (invoke #$umount          #$destination))))
+              #f))
+         (start
+          #~(lambda args
+              (define (mkdir-recursively dir user group)
+                ;; Like mkdir-p, but chown all created directories to the
+                ;; specified user.
+                (unless (eq? dir "/")
+                  (when (not (file-exists? dir))
+                    (mkdir-recursively (dirname dir) user group)
+                    (mkdir dir)
+                    (let* ((pw (getpw user))
+                           (uid (passwd:uid pw))
+                           (gid (passwd:gid pw)))
+                      (chown dir uid gid)))))
+              (mkdir-recursively #$destination #$user #$group)
+              (let* ((stat (stat #$source))
+                     (uid (stat:uid stat))
+                     (gid (stat:gid stat))
+                     (source-user (passwd:name (getpwuid uid)))
+                     (source-group (group:name (getgrgid gid))))
+                (match (quote #$policy)
+                  ('bind
+                   (mount #$source #$destination
+                          #f              ;type
+                          MS_BIND))       ;flags (bind mount)
+                  ('translate
+                   (invoke
+                    #$bindfs
+                    (string-append "--create-for-group=" source-group)
+                    (string-append "--create-for-user="  source-user)
+                    (string-append "--force-user="       #$user)
+                    (string-append "--force-group="      #$group)
+                    "-o" "nonempty"
+                    #$source #$destination))
+                  ('overlay
+                   (let ((overlay (string-append #$destination "-overlay"))
+                         (workdir (string-append #$destination "-workdir")))
+                     (mkdir-recursively overlay #$user #$group)
+                     (mkdir-recursively workdir #$user #$group)
+                     (mount "overlay"   ;source
+                            #$destination
+                            "overlay"      ;type
+                            0              ;flags
+                            (string-append ;options
+                             "lowerdir=" #$source ","
+                             "upperdir=" overlay  ","
+                             "workdir="  workdir))
+                     ;; Remount the target over itself to make it appear as if
+                     ;; owned by user-name and user-group.
+                     (invoke
+                      #$bindfs
+                      (string-append "--create-for-group="  source-group)
+                      (string-append "--create-for-user=" source-user)
+                      (string-append "--force-user="      #$user)
+                      (string-append "--force-group="     #$group)
+                      #$destination #$destination)))))
+              #t))))
+     bindings)))
+
+(define vfs-mapping-service-type
+  (service-type
+   (name 'vfs-mapping)
+   (extensions (list
+                (service-extension shepherd-root-service-type
+                                   vfs-mapping-shepherd-services)))
+   (compose concatenate)
+   (extend (lambda (original extensions)
+             (vfs-mapping-configuration
+              (inherit original)
+              (bindings (append (vfs-mapping-configuration-bindings original)
+                                extensions)))))
+   (default-value (vfs-mapping-configuration))
+   (description "Share or expose a file name under a different name.")))