mirror of
https://codeberg.org/guix/guix.git
synced 2026-01-25 12:05:19 -06:00
fa4aba28a0
* 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
950 lines
36 KiB
Scheme
950 lines
36 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2016, 2025 John Darrington <jmd@gnu.org>
|
||
;;; Copyright © 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
|
||
;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim@guixotic.coop>
|
||
;;; Copyright © 2023-2025 Ian Eure <ian@retrospec.tv>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (gnu services nfs)
|
||
#:use-module (gnu build file-systems)
|
||
#:use-module (gnu packages file-systems)
|
||
#:use-module (gnu packages linux)
|
||
#:use-module (gnu packages nfs)
|
||
#: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 (srfi srfi-171)
|
||
#:use-module (ice-9 match)
|
||
#:export (rpcbind-service-type
|
||
rpcbind-configuration
|
||
rpcbind-configuration?
|
||
|
||
pipefs-service-type
|
||
pipefs-configuration
|
||
pipefs-configuration?
|
||
|
||
idmap-service-type
|
||
idmap-configuration
|
||
idmap-configuration?
|
||
|
||
gss-service-type
|
||
gss-configuration
|
||
gss-configuration?
|
||
|
||
nfs-service-type
|
||
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")
|
||
|
||
|
||
|
||
(define-record-type* <rpcbind-configuration>
|
||
rpcbind-configuration make-rpcbind-configuration
|
||
rpcbind-configuration?
|
||
(rpcbind rpcbind-configuration-rpcbind
|
||
(default rpcbind))
|
||
(warm-start? rpcbind-configuration-warm-start?
|
||
(default #t)))
|
||
|
||
(define rpcbind-service-type
|
||
(let ((proc
|
||
(lambda (config)
|
||
(define rpcbind
|
||
(rpcbind-configuration-rpcbind config))
|
||
|
||
(define rpcbind-command
|
||
#~(list (string-append #$rpcbind "/sbin/rpcbind") "-f"
|
||
#$@(if (rpcbind-configuration-warm-start? config) '("-w") '())))
|
||
|
||
(shepherd-service
|
||
(documentation "Start the RPC bind daemon.")
|
||
(requirement '(user-processes networking))
|
||
(provision '(rpcbind-daemon))
|
||
|
||
(start #~(make-forkexec-constructor #$rpcbind-command))
|
||
(stop #~(make-kill-destructor))))))
|
||
(service-type
|
||
(name 'rpcbind)
|
||
(extensions
|
||
(list (service-extension shepherd-root-service-type
|
||
(compose list proc))))
|
||
;; We use the extensions feature to allow other services to automatically
|
||
;; configure and start this service. Only one value can be provided. We
|
||
;; override it with the value returned by the extending service.
|
||
(compose identity)
|
||
(extend (lambda (config values)
|
||
(match values
|
||
((first . rest) first)
|
||
(_ config))))
|
||
(default-value (rpcbind-configuration))
|
||
(description "Run the RPC Bind service, which provides a facility to map
|
||
ONC RPC program numbers into universal addresses. Many NFS related services
|
||
use this facility."))))
|
||
|
||
|
||
|
||
(define-record-type* <pipefs-configuration>
|
||
pipefs-configuration make-pipefs-configuration
|
||
pipefs-configuration?
|
||
(mount-point pipefs-configuration-mount-point
|
||
(default default-pipefs-directory)))
|
||
|
||
(define pipefs-service-type
|
||
(let ((proc
|
||
(lambda (config)
|
||
(define pipefs-directory (pipefs-configuration-mount-point config))
|
||
|
||
(shepherd-service
|
||
(documentation "Mount the pipefs pseudo file system.")
|
||
(provision '(rpc-pipefs))
|
||
|
||
(start #~(lambda ()
|
||
(mkdir-p #$pipefs-directory)
|
||
(mount "rpc_pipefs" #$pipefs-directory "rpc_pipefs")
|
||
(member #$pipefs-directory (mount-points))))
|
||
|
||
(stop #~(lambda (pid . args)
|
||
(umount #$pipefs-directory MNT_DETACH)
|
||
(not (member #$pipefs-directory (mount-points)))))))))
|
||
(service-type
|
||
(name 'pipefs)
|
||
(extensions
|
||
(list (service-extension shepherd-root-service-type
|
||
(compose list proc))))
|
||
;; We use the extensions feature to allow other services to automatically
|
||
;; configure and start this service. Only one value can be provided. We
|
||
;; override it with the value returned by the extending service.
|
||
(compose identity)
|
||
(extend (lambda (config values)
|
||
(match values
|
||
((first . rest) first)
|
||
(_ config))))
|
||
(default-value (pipefs-configuration))
|
||
(description "Mount the pipefs file system, which is used to transfer
|
||
NFS-related data between the kernel and user-space programs."))))
|
||
|
||
|
||
|
||
(define-record-type* <gss-configuration>
|
||
gss-configuration make-gss-configuration
|
||
gss-configuration?
|
||
(pipefs-directory gss-configuration-pipefs-directory
|
||
(default default-pipefs-directory))
|
||
(nfs-utils gss-configuration-gss
|
||
(default nfs-utils)))
|
||
|
||
(define gss-service-type
|
||
(let ((proc
|
||
(lambda (config)
|
||
(define nfs-utils
|
||
(gss-configuration-gss config))
|
||
|
||
(define pipefs-directory
|
||
(gss-configuration-pipefs-directory config))
|
||
|
||
(define gss-command
|
||
#~(list (string-append #$nfs-utils "/sbin/rpc.gssd") "-f"
|
||
"-p" #$pipefs-directory))
|
||
|
||
(shepherd-service
|
||
(documentation "Start the RPC GSS daemon.")
|
||
(requirement '(user-processes rpcbind-daemon rpc-pipefs))
|
||
(provision '(gss-daemon))
|
||
|
||
(start #~(make-forkexec-constructor #$gss-command))
|
||
(stop #~(make-kill-destructor))))))
|
||
(service-type
|
||
(name 'gss)
|
||
(extensions
|
||
(list (service-extension shepherd-root-service-type
|
||
(compose list proc))))
|
||
;; We use the extensions feature to allow other services to automatically
|
||
;; configure and start this service. Only one value can be provided. We
|
||
;; override it with the value returned by the extending service.
|
||
(compose identity)
|
||
(extend (lambda (config values)
|
||
(match values
|
||
((first . rest) first)
|
||
(_ config))))
|
||
(default-value (gss-configuration))
|
||
(description "Run the @dfn{global security system} (GSS) daemon, which
|
||
provides strong security for protocols based on remote procedure calls (ONC
|
||
RPC)."))))
|
||
|
||
|
||
|
||
(define-record-type* <idmap-configuration>
|
||
idmap-configuration make-idmap-configuration
|
||
idmap-configuration?
|
||
(pipefs-directory idmap-configuration-pipefs-directory
|
||
(default default-pipefs-directory))
|
||
(domain idmap-configuration-domain
|
||
(default #f))
|
||
(nfs-utils idmap-configuration-nfs-utils
|
||
(default nfs-utils))
|
||
(verbosity idmap-configuration-verbosity
|
||
(default 0)))
|
||
|
||
(define idmap-service-type
|
||
(let ((proc
|
||
(lambda (config)
|
||
|
||
(define nfs-utils
|
||
(idmap-configuration-nfs-utils config))
|
||
|
||
(define pipefs-directory
|
||
(idmap-configuration-pipefs-directory config))
|
||
|
||
(define domain (idmap-configuration-domain config))
|
||
|
||
(define (idmap-config-file config)
|
||
(plain-file "idmapd.conf"
|
||
(string-append
|
||
"\n[General]\n"
|
||
"Verbosity = "
|
||
(number->string
|
||
(idmap-configuration-verbosity config))
|
||
"\n"
|
||
(if domain
|
||
(format #f "Domain = ~a\n" domain)
|
||
"")
|
||
"\n[Mapping]\n"
|
||
"Nobody-User = nobody\n"
|
||
"Nobody-Group = nogroup\n")))
|
||
|
||
(define idmap-command
|
||
#~(list (string-append #$nfs-utils "/sbin/rpc.idmapd") "-f"
|
||
"-p" #$pipefs-directory
|
||
;; TODO: this is deprecated
|
||
"-c" #$(idmap-config-file config)))
|
||
|
||
(shepherd-service
|
||
(documentation "Start the RPC IDMAP daemon.")
|
||
(requirement '(user-processes rpcbind-daemon rpc-pipefs))
|
||
(provision '(idmap-daemon))
|
||
(start #~(make-forkexec-constructor #$idmap-command))
|
||
(stop #~(make-kill-destructor))))))
|
||
(service-type
|
||
(name 'idmap)
|
||
(extensions
|
||
(list (service-extension shepherd-root-service-type
|
||
(compose list proc))))
|
||
;; We use the extensions feature to allow other services to automatically
|
||
;; configure and start this service. Only one value can be provided. We
|
||
;; override it with the value returned by the extending service.
|
||
(compose identity)
|
||
(extend (lambda (config values) (first values)))
|
||
(default-value (idmap-configuration))
|
||
(description "Run the idmap daemon, which provides a mapping between user
|
||
IDs and user names. It is typically required to access file systems mounted
|
||
via NFSv4."))))
|
||
|
||
(define-record-type* <nfs-configuration>
|
||
nfs-configuration make-nfs-configuration
|
||
nfs-configuration?
|
||
(nfs-utils nfs-configuration-nfs-utils
|
||
(default nfs-utils))
|
||
(nfs-versions nfs-configuration-nfs-versions
|
||
(default '("4.2" "4.1" "4.0")))
|
||
(exports nfs-configuration-exports
|
||
(default '()))
|
||
(rpcmountd-port nfs-configuration-rpcmountd-port
|
||
(default #f))
|
||
(rpcstatd-port nfs-configuration-rpcstatd-port
|
||
(default #f))
|
||
(rpcbind nfs-configuration-rpcbind
|
||
(default rpcbind))
|
||
(idmap-domain nfs-configuration-idmap-domain
|
||
(default "localdomain"))
|
||
(nfsd-port nfs-configuration-nfsd-port
|
||
(default 2049))
|
||
(nfsd-threads nfs-configuration-nfsd-threads
|
||
(default 8))
|
||
(nfsd-tcp? nfs-configuration-nfsd-tcp?
|
||
(default #t))
|
||
(nfsd-udp? nfs-configuration-nfsd-udp?
|
||
(default #f))
|
||
(pipefs-directory nfs-configuration-pipefs-directory
|
||
(default default-pipefs-directory))
|
||
;; List of modules to debug; any of nfsd, nfs, rpc, idmap, statd, or mountd.
|
||
(debug nfs-configuration-debug
|
||
(default '())))
|
||
|
||
(define (nfs-shepherd-services config)
|
||
"Return a list of <shepherd-service> for the NFS daemons with CONFIG."
|
||
(match-record config <nfs-configuration>
|
||
(nfs-utils nfs-versions exports
|
||
rpcmountd-port rpcstatd-port nfsd-port nfsd-threads
|
||
nfsd-tcp? nfsd-udp?
|
||
pipefs-directory debug)
|
||
(list (shepherd-service
|
||
(documentation "Mount the nfsd pseudo file system.")
|
||
(provision '(/proc/fs/nfsd))
|
||
(start #~(lambda ()
|
||
(mount "nfsd" "/proc/fs/nfsd" "nfsd")
|
||
(member "/proc/fs/nfsd" (mount-points))))
|
||
|
||
(stop #~(lambda (pid . args)
|
||
(umount "/proc/fs/nfsd" MNT_DETACH)
|
||
(not (member "/proc/fs/nfsd" (mount-points))))))
|
||
(shepherd-service
|
||
(documentation "Run the NFS statd daemon.")
|
||
(provision '(rpc.statd))
|
||
(requirement '(/proc/fs/nfsd rpcbind-daemon))
|
||
(start
|
||
#~(make-forkexec-constructor
|
||
(list #$(file-append nfs-utils "/sbin/rpc.statd")
|
||
;; TODO: notification support may require a little more
|
||
;; configuration work.
|
||
"--no-notify"
|
||
#$@(if (member 'statd debug)
|
||
'("--no-syslog") ; verbose logging to stderr
|
||
'())
|
||
"--foreground"
|
||
#$@(if rpcstatd-port
|
||
#~("--port" #$(number->string rpcstatd-port))
|
||
'()))
|
||
#:pid-file "/var/run/rpc.statd.pid"))
|
||
(stop #~(make-kill-destructor)))
|
||
(shepherd-service
|
||
(documentation "Run the NFS mountd daemon.")
|
||
(provision '(rpc.mountd))
|
||
(requirement '(/proc/fs/nfsd rpc.statd))
|
||
(start
|
||
#~(make-forkexec-constructor
|
||
(list #$(file-append nfs-utils "/sbin/rpc.mountd")
|
||
"--foreground"
|
||
#$@(if (member 'mountd debug)
|
||
'("--debug" "all")
|
||
'())
|
||
#$@(if rpcmountd-port
|
||
#~("--port" #$(number->string rpcmountd-port))
|
||
'()))))
|
||
(stop #~(make-kill-destructor)))
|
||
(shepherd-service
|
||
(documentation "Run the NFS daemon.")
|
||
(provision '(rpc.nfsd))
|
||
(requirement '(/proc/fs/nfsd rpc.statd networking))
|
||
(start
|
||
#~(lambda _
|
||
(zero? (apply system* #$(file-append nfs-utils "/sbin/rpc.nfsd")
|
||
(list
|
||
#$@(if (member 'nfsd debug)
|
||
'("--debug")
|
||
'())
|
||
"--port" #$(number->string nfsd-port)
|
||
#$@(map (lambda (version)
|
||
(string-append "--nfs-version=" version))
|
||
nfs-versions)
|
||
#$(number->string nfsd-threads)
|
||
#$(if nfsd-tcp?
|
||
"--tcp"
|
||
"--no-tcp")
|
||
#$(if nfsd-udp?
|
||
"--udp"
|
||
"--no-udp"))))))
|
||
(stop
|
||
#~(lambda _
|
||
(zero?
|
||
(system* #$(file-append nfs-utils "/sbin/rpc.nfsd") "0")))))
|
||
(shepherd-service
|
||
(documentation "Run the NFS mountd daemon and refresh exports.")
|
||
(provision '(nfs))
|
||
(requirement '(/proc/fs/nfsd rpc.nfsd rpc.mountd rpc.statd rpcbind-daemon))
|
||
(start
|
||
#~(lambda _
|
||
(let ((rpcdebug #$(file-append nfs-utils "/sbin/rpcdebug")))
|
||
(cond
|
||
((member 'nfsd '#$debug)
|
||
(system* rpcdebug "-m" "nfsd" "-s" "all"))
|
||
((member 'nfs '#$debug)
|
||
(system* rpcdebug "-m" "nfs" "-s" "all"))
|
||
((member 'rpc '#$debug)
|
||
(system* rpcdebug "-m" "rpc" "-s" "all"))))
|
||
(zero? (system*
|
||
#$(file-append nfs-utils "/sbin/exportfs")
|
||
"-r" ; re-export
|
||
"-a" ; everthing
|
||
"-v" ; be verbose
|
||
"-d" "all" ; debug
|
||
))))
|
||
(stop
|
||
#~(lambda _
|
||
(let ((rpcdebug #$(file-append nfs-utils "/sbin/rpcdebug")))
|
||
(cond
|
||
((member 'nfsd '#$debug)
|
||
(system* rpcdebug "-m" "nfsd" "-c" "all"))
|
||
((member 'nfs '#$debug)
|
||
(system* rpcdebug "-m" "nfs" "-c" "all"))
|
||
((member 'rpc '#$debug)
|
||
(system* rpcdebug "-m" "rpc" "-c" "all"))))
|
||
#t))
|
||
(respawn? #f)))))
|
||
|
||
(define %nfs-activation
|
||
(with-imported-modules '((guix build utils))
|
||
#~(begin
|
||
(use-modules (guix build utils))
|
||
|
||
;; directory containing monitor list
|
||
(mkdir-p "/var/lib/nfs/sm")
|
||
;; Needed for client recovery tracking
|
||
(mkdir-p "/var/lib/nfs/v4recovery")
|
||
(let ((user (getpw "nobody")))
|
||
(chown "/var/lib/nfs"
|
||
(passwd:uid user)
|
||
(passwd:gid user))
|
||
(chown "/var/lib/nfs/v4recovery"
|
||
(passwd:uid user)
|
||
(passwd:gid user)))
|
||
#t)))
|
||
|
||
(define nfs-service-type
|
||
(service-type
|
||
(name 'nfs)
|
||
(extensions
|
||
(list
|
||
(service-extension shepherd-root-service-type nfs-shepherd-services)
|
||
(service-extension activation-service-type (const %nfs-activation))
|
||
(service-extension etc-service-type
|
||
(lambda (config)
|
||
`(("exports"
|
||
,(plain-file "exports"
|
||
(string-join
|
||
(map string-join
|
||
(nfs-configuration-exports config))
|
||
"\n"))))))
|
||
;; The NFS service depends on these other services. They are extended so
|
||
;; that users don't need to configure them manually.
|
||
(service-extension idmap-service-type
|
||
(lambda (config)
|
||
(idmap-configuration
|
||
(domain (nfs-configuration-idmap-domain config))
|
||
(verbosity
|
||
(if (member 'idmap (nfs-configuration-debug config))
|
||
10 0))
|
||
(pipefs-directory (nfs-configuration-pipefs-directory config))
|
||
(nfs-utils (nfs-configuration-nfs-utils config)))))
|
||
(service-extension pipefs-service-type
|
||
(lambda (config)
|
||
(pipefs-configuration
|
||
(mount-point (nfs-configuration-pipefs-directory config)))))
|
||
(service-extension rpcbind-service-type
|
||
(lambda (config)
|
||
(rpcbind-configuration
|
||
(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 (value->string _ value)
|
||
(object->string value display))
|
||
|
||
(define (option-flag? value)
|
||
"Is @var{value} a mount option flag?
|
||
Option flags are value like @var{ro}, @var{noatime}, @var{nosuid}, etc."
|
||
(or (string? value)
|
||
(symbol? value)))
|
||
|
||
(define (option-value? value)
|
||
(or (option-flag? value)
|
||
(integer? value)))
|
||
|
||
(define (option-pair? value)
|
||
"Is @var{value} 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."
|
||
(match value
|
||
(((? option-flag? _) . (? option-value? _)) #t)
|
||
(_ #f)))
|
||
|
||
(define (serialize-option-pair name value)
|
||
(match value
|
||
((option-flag . option-value)
|
||
(string-append (value->string name option-flag)
|
||
"="
|
||
(value->string name option-value)))))
|
||
|
||
(define (file-system-option? value)
|
||
(or (option-flag? value)
|
||
(option-pair? value)))
|
||
|
||
(define (serialize-file-system-option name value)
|
||
(cond
|
||
((option-flag? value) (value->string name value))
|
||
((option-pair? value) (serialize-option-pair name value))))
|
||
|
||
(define (file-system-options? value)
|
||
(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."
|
||
(serializer value->string))
|
||
(device string
|
||
"Device or remote host to mount. May contain special
|
||
character @code{&}, which can be referenced in the @var{mount-point}
|
||
field."
|
||
(serializer value->string))
|
||
(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/&\")))))"
|
||
(serializer value->string))
|
||
(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)
|
||
(value->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"
|
||
'suffix))
|
||
|
||
(define-configuration autofs-indirect-map
|
||
(mount-point string "Where to mount the indirect map."
|
||
(serializer value->string))
|
||
(entries (autofs-map-entries '()) "Entries in this map."))
|
||
|
||
(define (autofs-serialize-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? value)
|
||
(and (autofs-map-entry? value)
|
||
(autofs-direct-mount-point? (autofs-map-entry-mount-point value))))
|
||
|
||
(define (mount-map? value)
|
||
(or (autofs-direct-map? value)
|
||
(autofs-indirect-map? value)))
|
||
|
||
(define (mount-maps? value)
|
||
(list-of mount-map?))
|
||
|
||
(define (scheme->autofs name-sym)
|
||
(string-replace-substring
|
||
(string-replace-substring (symbol->string name-sym) "-" "_")
|
||
"?" ""))
|
||
|
||
(define (autofs-serialize-integer name value)
|
||
(format #f "~a = ~a" (scheme->autofs name) value))
|
||
|
||
(define (autofs-serialize-boolean name value)
|
||
(format #f "~a = ~a" (scheme->autofs name) (if value "yes" "no")))
|
||
|
||
(define (log-level? value)
|
||
(and (keyword? value)
|
||
(member value '(#:none #:verbose #:debug))))
|
||
|
||
(define (autofs-serialize-log-level name value)
|
||
(format #f "~a = ~a" (scheme->autofs name)
|
||
(symbol->string (keyword->symbol value))))
|
||
|
||
(define-configuration autofs-configuration
|
||
(autofs
|
||
(package autofs)
|
||
"The autofs package to use."
|
||
(serializer empty-serializer))
|
||
|
||
(mounts
|
||
(mount-maps '())
|
||
"Mount maps to manage.
|
||
|
||
This is a list of either direct map entries or indirect mount maps."
|
||
(serializer empty-serializer))
|
||
|
||
(timeout
|
||
(integer 300)
|
||
"Sets the default mount timeout in seconds.")
|
||
|
||
(master-wait
|
||
(integer 10)
|
||
"Sets the default maximum number of retries (actual iterations is half
|
||
this, each is delayed by 2 seconds before retrying) waiting for the master map
|
||
to become available if it cannot be read at program start. This can be longer
|
||
if the map source itself waits for availability (such as sss).")
|
||
|
||
(negative-timeout
|
||
(integer 60)
|
||
"Set the default timeout for caching failed key lookups.")
|
||
|
||
(mount-verbose?
|
||
(boolean #f)
|
||
"Use the verbose flag when spawning mount(8), and log some process info
|
||
about the requestor and its parent.")
|
||
|
||
(mount-wait
|
||
(integer -1)
|
||
"Set the default time to wait for a response from a spawned mount(8) before
|
||
sending it a SIGTERM. Note that we still need to wait for the RPC layer to
|
||
timeout before the sub-process exits so this isn't ideal but it is the best we
|
||
can do. The default is to wait until mount(8) returns without intervention.")
|
||
|
||
(umount-wait
|
||
(integer 12)
|
||
"Set the default time to wait for a response from a spawned umount(8)
|
||
before sending it a SIGTERM. Note that we still need to wait for the RPC layer
|
||
to timeout before the sub-process exits so this isn't ideal but it is the best
|
||
we can do.")
|
||
|
||
(browse-mode?
|
||
(boolean #t)
|
||
"Should maps be browsable by default?")
|
||
|
||
(mount-nfs-default-protocol
|
||
(integer 3)
|
||
"Set the default protocol that mount.nfs(8) uses when performing a mount.
|
||
Autofs needs to know the default NFS protocol that mount.nfs(8) uses so it can
|
||
do special case handling for its availability probe for different NFS
|
||
protocols. Since we can't identify this default automatically we need to set
|
||
it in the autofs configuration.")
|
||
|
||
(append-options?
|
||
(boolean #t)
|
||
"When #t, global options are appended to map entry options. When #f, map
|
||
entry options replace the global options.")
|
||
|
||
(logging
|
||
(log-level #:none)
|
||
"Default log level. May be #:none, #:verbose, or #:debug.")
|
||
|
||
(force-standard-program-map-env?
|
||
(boolean #f)
|
||
"Override the use of a prefix with standard environment variables when a
|
||
program map is executed. Since program maps are run as the privileged user
|
||
setting these standard environment variables opens automount(8) to potential
|
||
user privilege escalation when the program map is written in a language that
|
||
can load components from, for example, a user home directory.")
|
||
|
||
(map-hash-table-size
|
||
(integer 1024)
|
||
"This configuration option may be used to change the number of hash table
|
||
slots.
|
||
|
||
This configuration option affects the overhead of searching the map entry
|
||
cache for map entries when there are a large number of entries. It affects
|
||
the number of entries that must be looked at to locate a map entry in the map
|
||
entry cache. For example, the default of 1024 and a direct map with 8000
|
||
entries would result in each slot containing an average of 8 entries, which
|
||
should be acceptable.
|
||
|
||
However, if excessive CPU usage is observed during automount lookups
|
||
increasing this option can reduce the CPU overhead considerably because it
|
||
reduces the length of the search chains.
|
||
|
||
Note that the number of entries in a map doesn't necessarily relate to the
|
||
number of entries used in the map entry cache.
|
||
|
||
There are two distinct cases where the map hash table can make a significant
|
||
difference, direct maps and indirect maps that use the \"browse\" option.
|
||
|
||
For indirect maps that do not use the \"browse\" option entries are added to
|
||
the map entry cache at lookup so the number of active cache entries, in this
|
||
case, is usually much less than the number of entries in the map. In this
|
||
last case it would be unusual for the map entry cache to grow large enough to
|
||
warrant increasing the default before an event that cleans stale entries, a
|
||
map re-read for example.")
|
||
|
||
(use-hostname-for-mounts?
|
||
(boolean #f)
|
||
"NFS mounts where the host name resolves to more than one IP address are
|
||
probed for availability and to establish the order in which mounts to them
|
||
should be tried. To ensure that mount attempts are made only to hosts that
|
||
are responding and are tried in the order of hosts with the quickest response
|
||
the IP address of the host needs to be used for the mount.
|
||
|
||
If it is necessary to use the hostname given in the map entry for the mount
|
||
regardless, then set this option to #t.
|
||
|
||
Be aware that if this is done there is no defense against the host name
|
||
resolving to one that isn't responding and while the number of attempts at a
|
||
successful mount will correspond to the number of addresses the host name
|
||
resolves to the order will also not correspond to fastest responding hosts.")
|
||
|
||
(disable-not-found-message?
|
||
(boolean #f)
|
||
"The original request to add this log message needed it to be
|
||
unconditional. That produces, IMHO, unnecessary noise in the log so a
|
||
configuration option has been added to provide the ability to turn it off.")
|
||
|
||
(use-ignore-mount-option?
|
||
(boolean #f)
|
||
"An option to enable the use of autofs pseudo option \"disable\". This
|
||
option is used as a hint to user space that the mount entry should be omitted
|
||
from mount table listings. The default is #f to avoid unexpected changes in
|
||
behaviour and so is an opt-in setting.")
|
||
|
||
(sss-master-map-wait
|
||
(integer 0)
|
||
"Set the time to wait and retry if sssd is unable to read the master map at
|
||
program start. Default is 0 (don't wait) or 10 if sss supports returning
|
||
EHSTDOWN when the provider isn't available.
|
||
|
||
If the sss library upports returning EHOSTDOWN when the provider is down then
|
||
this value is how long to wait between re‐ tries reading the master map. When
|
||
reading dependent maps or looking up a map key this value is multiplied by the
|
||
number of retries that would be used when reading the master map.")
|
||
|
||
(use-mount-request-log-id?
|
||
(boolean #f)
|
||
"Set whether to use a mount request log id so that log entries for specific
|
||
mount requests can be easily identified in logs that have multiple concurrent
|
||
requests.")
|
||
(prefix autofs-))
|
||
|
||
(define (indirect-map->file-name indirect-map)
|
||
(string-append
|
||
(string-replace-substring
|
||
(substring (autofs-indirect-map-mount-point indirect-map) 1)
|
||
"/" "-") ".map"))
|
||
|
||
(define (autofs-build-config config)
|
||
(let* ((mounts (autofs-configuration-mounts config))
|
||
(autofs-conf (list-transduce (base-transducer config) rcons
|
||
autofs-configuration-fields))
|
||
;; List of serialized direct maps.
|
||
(direct-maps
|
||
(serialize-autofs-map-entries
|
||
#f (filter autofs-direct-map? mounts)))
|
||
|
||
;; List of (file-name mount-point serialized-map).
|
||
(indirect-maps
|
||
(map
|
||
(lambda (indirect-map)
|
||
(list (indirect-map->file-name indirect-map)
|
||
(autofs-indirect-map-mount-point indirect-map)
|
||
(autofs-serialize-indirect-map #f indirect-map)))
|
||
(filter autofs-indirect-map? mounts))))
|
||
(computed-file
|
||
"autofs-config"
|
||
(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 "/autofs.conf")
|
||
(lambda (autofs-conf)
|
||
;; Write out the serialized config.
|
||
(display (string-join
|
||
(cons*
|
||
"[ autofs ]"
|
||
(string-append "master_map_name = "
|
||
#$output "/auto.master")
|
||
'#$autofs-conf)
|
||
"\n" 'suffix)
|
||
autofs-conf)))
|
||
|
||
;; Write out the master map.
|
||
(call-with-output-file (string-append #$output "/auto.master")
|
||
(lambda (master-map)
|
||
;; Write the direct entries to the master map.
|
||
(display '#$direct-maps master-map)
|
||
|
||
;; Write indirect maps to their own files.
|
||
(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* ((config-dir (autofs-build-config config))
|
||
(autofs-conf (file-append config-dir "/autofs.conf"))
|
||
(conf-link "/etc/autofs.conf")
|
||
(no-mounts? (null? (autofs-configuration-mounts config)))
|
||
(direct-mount-points
|
||
(map
|
||
autofs-map-entry-mount-point
|
||
(filter autofs-direct-map?
|
||
(autofs-configuration-mounts config))))
|
||
(indirect-mount-points
|
||
(map
|
||
autofs-indirect-map-mount-point
|
||
(filter
|
||
autofs-indirect-map?
|
||
(autofs-configuration-mounts config))))
|
||
(mount-points (append direct-mount-points indirect-mount-points)))
|
||
#~(begin
|
||
(use-modules (guix build utils))
|
||
(for-each mkdir-p (cons "/var/lib/nfs/sm" '#$mount-points))
|
||
(when (or (false-if-exception (lstat #$conf-link))
|
||
(stat #$conf-link #f))
|
||
(delete-file #$conf-link))
|
||
(unless #$no-mounts?
|
||
(symlink #$autofs-conf #$conf-link)))))
|
||
|
||
(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 to the service
|
||
requirements.
|
||
|
||
If @var{config} contains SMB mounts, adds samba-nmbd and samba-winbindd to the
|
||
service requirements.
|
||
"
|
||
(delete-duplicates
|
||
(fold
|
||
(lambda (fs-type acc)
|
||
(cond
|
||
((string= "nfs" fs-type)
|
||
(append acc '(rpc.statd)))
|
||
((string= "smb" fs-type)
|
||
(append acc '(samba-nmbd samba-winbindd)))))
|
||
'()
|
||
(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
|
||
;; Autofs doesn't let us specify the config file, so we rely on
|
||
;; autofs-activation linking /etc/autofs.conf to the store.
|
||
#~(list
|
||
#$(file-append autofs "/sbin/automount")
|
||
"-f"
|
||
"-t" (number->string #$timeout)
|
||
"-p" #$%autofs-pid-file))
|
||
|
||
(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 (autofs-configuration-merge a b)
|
||
(autofs-configuration
|
||
(inherit b)
|
||
(mounts (append (autofs-configuration-mounts a)
|
||
(autofs-configuration-mounts b)))))
|
||
|
||
(define-public autofs-service-type
|
||
(service-type
|
||
(name 'autofs)
|
||
(description "Run autofs")
|
||
(extensions
|
||
(list
|
||
(service-extension activation-service-type
|
||
autofs-activation)
|
||
(service-extension shepherd-root-service-type
|
||
autofs-shepherd-service)))
|
||
(compose
|
||
(cut reduce autofs-configuration-merge (autofs-configuration) <>))
|
||
(default-value (autofs-configuration))))
|