GNU bug report logs - #77106
[PATCH 0/1] Add autofs-service-type

Previous Next

To reply to this bug, email your comments to 77106 AT debbugs.gnu.org.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Ian Eure <ian <at> retrospec.tv>
To: guix-patches <at> gnu.org
Cc: Ian Eure <ian <at> retrospec.tv>
Subject: [PATCH 0/1] Add autofs-service-type
Date: Tue, 18 Mar 2025 17:14:20 -0700

This is a draft of a system service to manage autofs, the lack of which has
been an impediment to my daily-driver experience with Guix.  It’s in working
status, but incomplete (missing documentation) and may need other
adjustments.  I’m seeking feedback now, so I don’t waste time writing
documentation for a moving target.

What it does:

- Lets you declaratively configure autofs in your operating-system.
- Computes requirements based on the configuration, ex. if you have all local
  mounts, no requirements are added, but if you configure NFS mounts, it
  requires networking and rpc.statd services.
- Supports direct mounts and indirect maps.
- Flexibly supports any filesystem and mount options.
- Creates mountpoints on service activation.
- Most important of all, Works On My Machine.

What it lacks:

- Support for many autofs options, ex. verbose logging, "timeout for caching
  failed key lookups," a handful of others.  I’ll add these in later
  versions of the patch.

- Support for options per indirect map, ex no/browse, timeout, etc.  I can add
  these if desired, but it’s somewhat annoying to do so.

- Support for autofs maps other than the "file" type.  Autofs supports many
  map formats, including esoteric things like maps stored in hesiod, nis, yp,
  ldap, etc.  Most of these require fairly involved configuration, and are
  difficult to validate -- I don’t run hesiod or LDAP -- so I’ve omited them.
  The "file" type covers the majority of usecases.  It’s possible to extend
  this patch to support them, should someone be motivated to do so.

- Documentation.  I want the code to be firmed up more before writing this.
  There are also some descriptions that need expanding.

Areas which could use attention:

- I’m not completely happy with how the config serializer works, for example,
  the `name' argument is mostly not used.  I’m not sure if the model for this
  is a poor fit for my usecase or if I’m using it wrong.  Feedback appreciated
  here.

- I opted to use a loose configuration setup for mount options, where they’re
  specified as arbitrary lists.  Options in the form `'(noatime (remount . ro)
  (wsize . 8192))' result in `noatime,remount=ro,wsize=8192'.  While I think
  it might be nice to have fully explicit options, this would require very
  large configuration records, one per supported filesystem.  I decided the
  cost-benefit wasn’t there.

  I considered reusing the `file-system' record from (gnu system
  file-systems), but it’s a poor match for this usecase, as it includes many
  irrelevant fields.

- The name.  I went with autofs-service-type to match the package, but
  "automount" is the name of the actual binary, and they’re used fairly
  interchangeably.  It `provides' both autofs and automount.

- Autofs itself doesn’t let you specify a configuration file and hardcodes the
  path to it (/etc/autofs.conf).  Currently, the service doesn’t create one at
  all (it specifies the supported arguments on the command line), so autofs
  complains about that.  I could add config file support if desired, but on a
  scale from One to Jazzed about it, I am Not Jazzed.


Ian Eure (1):
  gnu: Add autofs-service-type.

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

-- 
2.48.1

Message #8 received at 77106 <at> debbugs.gnu.org (full text, mbox):

From: Ian Eure <ian <at> retrospec.tv>
To: 77106 <at> debbugs.gnu.org
Cc: Ian Eure <ian <at> retrospec.tv>
Subject: [PATCH 1/1] gnu: Add autofs-service-type.
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 <jmd <at> gnu.org>
 ;;; Copyright © 2018, 2019, 2020 Ricardo Wurmus <rekado <at> elephly.net>
 ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
+;;; Copyright © 2023-2025 Ian Eure <ian <at> retrospec.tv>
 ;;;
 ;;; 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

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.