Subject: [bug#77106] [PATCH 1/1] gnu: Add autofs-service-type.

From: Ian Eure <[email-masked]>
Date: Tue, 18 Mar 2025 17:15:32 -0700

* gnu/services/nfs.scm (autofs-service-type): New variable.
(<autofs-configuration>): New record.
(<autofs-indirect-map>): New record.
(<autofs-map-entry>): New record.

Change-Id: I4ed1862772001470d1214c3061a306440b0d775b
---
 gnu/services/nfs.scm | 305 ++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 299 insertions(+), 6 deletions(-)

diff --git a/gnu/services/nfs.scm b/gnu/services/nfs.scm
index f5a1c6a44e..2321e4d056 100644
--- a/gnu/services/nfs.scm
+++ b/gnu/services/nfs.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2016 John Darrington <[email-masked]>
 ;;; Copyright © 2018, 2019, 2020 Ricardo Wurmus <[email-masked]>
 ;;; Copyright © 2020, 2021 Maxim Cournoyer <[email-masked]>
+;;; Copyright © 2023-2025 Ian Eure <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,16 +20,21 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu services nfs)
-  #:use-module (gnu)
-  #:use-module (gnu services shepherd)
-  #:use-module (gnu packages onc-rpc)
+  #:use-module (gnu build file-systems)
+  #:use-module (gnu packages file-systems)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages nfs)
-  #:use-module (guix)
+  #:use-module (gnu packages onc-rpc)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
   #:use-module (guix records)
+  #:use-module (guix)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
-  #:use-module (gnu build file-systems)
   #:export (rpcbind-service-type
             rpcbind-configuration
             rpcbind-configuration?
@@ -47,7 +53,17 @@ (define-module (gnu services nfs)
 
             nfs-service-type
             nfs-configuration
-            nfs-configuration?))
+            nfs-configuration?
+
+            autofs-service-type
+            autofs-configuration
+            autofs-configuration?
+
+            autofs-indirect-map
+            autofs-indirect-map?
+
+            autofs-map-entry
+            autofs-map-entry?))

 (define default-pipefs-directory "/var/lib/nfs/rpc_pipefs")
@@ -451,3 +467,280 @@ (define nfs-service-type
                            (rpcbind (nfs-configuration-rpcbind config)))))))
    (description
     "Run all NFS daemons and refresh the list of exported file systems.")))
+
+ ;; Autofs
+
+(define %autofs-pid-file "/var/run/autofs.pid")
+
+(define (serialize-string _ x) x)
+
+(define (serialize-option-flag _ value)
+  (format #f "~a" value))
+
+(define (option-flag? x)
+  "Is @var{x} a mount option flag?
+Option flags are value like @var{ro}, @var{noatime}, @var{nosuid}, etc."
+  (or (string? x)
+      (symbol? x)))
+
+(define (option-value? x)
+  (or (option-flag? x)
+      (integer? x)))
+
+(define (option-pair? x)
+  "Is @var{x} an option pair?
+Option pairs are cons cells of (option-flag . option-value), used for
+mount options like @{var errors=remount-ro}, @var{timeo=600}, etc."
+  (and (pair? x)
+       (not (list? x))
+       (option-flag? (car x))
+       (option-value? (cdr x))))
+
+(define (serialize-option-pair name value)
+  (string-append (serialize-option-flag name (car value))
+                 "="
+                 (serialize-option-flag name (cdr value))))
+
+(define (file-system-option? x)
+  (or (option-flag? x)
+      (option-pair? x)))
+
+(define (serialize-file-system-option name x)
+  (cond
+   ((option-flag? x) (serialize-option-flag name x))
+   ((option-pair? x) (serialize-option-pair name x))))
+
+(define (file-system-options? x)
+  (list-of file-system-option?))
+
+(define (serialize-file-system-options name value)
+  (string-join (map (cut serialize-file-system-option name <>) value) ","))
+
+(define-configuration autofs-map-entry
+  (type (string "auto")
+        "The type of the filesystem.")
+  (device string
+          "Device or remote host to mount.  May contain special
+character @code{&}, which can be referenced in the @var{mount-point}
+field.")
+  (mount-point string
+               "Directory to mount this device on.
+
+Map entries come in two flavors: direct and indirect.  Direct entries
+map a single device to a single mountpoint, while indirect entries can
+map multiple devices to multiple mountpoints.
+
+A direct entry has a @var{mount-point} beginning with @code{/}, representing
+the absolute path of the directory to mount the device on.  For example:
+
+    (autofs-map-entry
+     (type \"ext4\")
+     (device \"/dev/sdb1\")
+     (mount-point \"/mnt/external-disk\"))
+
+An indirect entry has a @var{mount-point} not beginning with @code{/},
+representing the subdirectory within the parent indirect map for this
+entry.  Indirect maps may also use the special character @code{*},
+which will be replaced with the value of special character @code{&} in
+the @var{device} field of this entry.  For example:
+
+    (autofs-indirect-map
+      (mount-point \"/devices\")
+      (entries
+        (list
+          ;; Automount any block device r/o by ID.
+          (autofs-map-entry
+            (type \"auto\")
+            (mount-point \"ro/uuid/*\")
+            (device \"/dev/disk/by-id/&\")
+            (options '(ro)))
+          ;; Automount any block device by UUID.
+          (autofs-map-entry
+            (type \"auto\")
+            (mount-point \"rw/uuid/*\")
+            (device \"/dev/disk/by-uuid/&\")))))
+")
+  (options (file-system-options '())
+           "List of mount options.
+
+Some options are simple flags, such as ro, noexec, nosuid, etc.  These
+may be expressed as strings or symbols.
+
+Other options also accept a value.  These are expressed as pairs of
+@code{(option . value)}.  @code{option} may be a string or symbol, as
+with flags.  @code{value} may be a string, symbol, or number.
+
+Example: @code{(ro (errors . remount-ro) noexec)}"))
+
+(define (serialize-autofs-map-entry _ value)
+  (let ((all-options
+         (serialize-file-system-options
+          #f
+          `((fstype . ,(autofs-map-entry-type value))
+            ,@(autofs-map-entry-options value)))))
+    (string-join (list (autofs-map-entry-mount-point value)
+                       (string-append "-" all-options)
+                       (serialize-string #f (autofs-map-entry-device value)))
+                 " ")))
+
+(define autofs-map-entries? (list-of autofs-map-entry?))
+
+(define (serialize-autofs-map-entries name value)
+  (string-join (map (cut serialize-autofs-map-entry name <>) value)
+               "\n"))
+
+(define-configuration autofs-indirect-map
+  (mount-point string "Where to mount the indirect map.")
+  (entries (autofs-map-entries '()) "Entries in this map."))
+
+(define (serialize-autofs-indirect-map name value)
+  (serialize-autofs-map-entries name (autofs-indirect-map-entries value)))
+
+(define (autofs-direct-mount-point? mount-point)
+  (string= "/" (substring mount-point 0 1)))
+
+(define (autofs-direct-map? x)
+  (and (autofs-map-entry? x)
+       (autofs-direct-mount-point? (autofs-map-entry-mount-point x))))
+
+(define (autofs-mount-map? x)
+  (or (autofs-direct-map? x)
+      (autofs-indirect-map? x)))
+
+(define (autofs-mount-maps? x)
+  (list-of autofs-mount-map?))
+
+(define (serialize-integer name value)
+  (format #f "~a" value))
+
+(define-configuration autofs-configuration
+  (autofs (package autofs) "The autofs package to use.")
+  (timeout (integer 300)
+           "Mount timeout, in seconds."
+           (serializer empty-serializer))
+  (mounts (autofs-mount-maps '())
+          "Mount maps to manage.
+
+This is a list of either direct map entries or indirect mount maps."
+          (serializer empty-serializer)))
+
+(define (indirect-map->file-name indirect-map)
+  (string-append
+   (string-replace-substring
+    (substring (autofs-indirect-map-mount-point indirect-map) 1)
+    "/" "-") ".map"))
+
+(define (config->maps config)
+  (let* ((mounts (autofs-configuration-mounts config))
+         (direct-maps
+          (map serialize-autofs-map-entry
+               (filter autofs-direct-map? mounts)))
+         (indirect-maps
+          (map
+           (lambda (indirect-map)
+             (list (indirect-map->file-name indirect-map)
+                   (autofs-indirect-map-mount-point indirect-map)
+                   (serialize-autofs-indirect-map #f indirect-map)))
+           (filter autofs-indirect-map? mounts))))
+    (computed-file
+     "autofs-maps"
+     (with-imported-modules
+         (source-module-closure '((guix build utils) (ice-9 match)))
+       #~(begin
+           (use-modules (guix build utils) (ice-9 match))
+
+           (mkdir-p #$output)
+
+           (call-with-output-file (string-append #$output "/auto.master")
+             (lambda (master-map)
+               ;; Write the direct entries to the master map.
+               (for-each (lambda (entry) (display entry master-map))
+                         '#$direct-maps)
+               (for-each
+                (match-lambda
+                  ((file-name mount-point content)
+                   ;; Write the indirect map.
+                   (call-with-output-file
+                       (string-append #$output "/" file-name)
+                     (lambda (indirect-map) (display content indirect-map)))
+                   ;; Reference it in the master map.
+                   (format master-map "~a ~a/~a"
+                           mount-point #$output file-name)))
+                '#$indirect-maps))))))))
+
+(define (autofs-activation config)
+  (let ((mount-points
+         (map
+          autofs-indirect-map-mount-point
+          (filter
+           autofs-indirect-map?
+           (autofs-configuration-mounts config)))))
+    #~(begin
+        (use-modules (guix build utils))
+        (mkdir-p "/var/lib/nfs/sm")
+        (for-each mkdir-p '#$mount-points))))
+
+(define (autofs-configuration->raw-entries config)
+  (fold
+   (lambda (mount acc)
+     (cond
+      ((autofs-direct-map? mount)
+       (cons mount acc))
+      ((autofs-indirect-map? mount)
+       (append (autofs-indirect-map-entries mount) acc))))
+   '()
+   (autofs-configuration-mounts config)))
+
+(define (autofs-configuration->requirements config)
+  "Compute Shepherd service requirements for @var{config}.
+
+If @var{config} contains NFS mounts, adds rpc.statd and networking to
+the service requirements.
+
+If @var{config} contains SMB mounts, adds networking to the service
+requirements.
+"
+  (delete-duplicates
+   (fold
+    (lambda (fs-type acc)
+      (cond
+       ((string= "nfs" fs-type)
+        (append acc '(networking rpc.statd)))
+       ((string= "smb" fs-type)
+        (cons 'networking acc))))
+    '()
+    (map autofs-map-entry-type (autofs-configuration->raw-entries config)))))
+
+(define (autofs-shepherd-service config)
+  (match-record config <autofs-configuration> (autofs timeout)
+    (begin
+      (define autofs-command
+        #~(list
+             #$(file-append autofs "/sbin/automount")
+             "-f"
+             "-t" (number->string #$timeout)
+             "-p" #$%autofs-pid-file
+             #$(file-append (config->maps config) "/auto.master")))
+
+      (list
+       (shepherd-service
+        (provision '(autofs automount))
+        (documentation "Run the autofs daemon.")
+        (requirement (autofs-configuration->requirements config))
+        (start
+         #~(make-forkexec-constructor
+            #$autofs-command
+            #:pid-file #$%autofs-pid-file))
+        (stop #~(make-kill-destructor)))))))
+
+(define-public autofs-service-type
+  (service-type
+   (name 'autofs)
+   (description "Run autofs")
+   (extensions
+    (list
+     (service-extension shepherd-root-service-type
+                        autofs-shepherd-service)
+     (service-extension activation-service-type
+                        autofs-activation)))
+   (default-value (autofs-configuration))))
-- 
2.48.1