Package: guix-patches;
Reported by: Ian Eure <ian <at> retrospec.tv>
Date: Wed, 19 Mar 2025 00:15:02 UTC
Severity: normal
Tags: patch
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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.