From patchwork Wed Mar 19 00:15:32 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Ian Eure X-Patchwork-Id: 40356 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 51B9527BBEA; Wed, 19 Mar 2025 00:16:35 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-7.6 required=5.0 tests=BAYES_00,DKIMWL_WL_HIGH, DKIM_SIGNED,DKIM_VALID,MAILING_LIST_MULTI,RCVD_IN_DNSWL_BLOCKED, RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE, SPF_HELO_PASS,URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id B447F27BBE2 for ; Wed, 19 Mar 2025 00:16:33 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tuh6h-00056z-RK; Tue, 18 Mar 2025 20:16:28 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tuh6N-000511-9M for guix-patches@gnu.org; Tue, 18 Mar 2025 20:16:10 -0400 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tuh6J-0005n0-00 for guix-patches@gnu.org; Tue, 18 Mar 2025 20:16:06 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:From:To:In-Reply-To:References:Subject; bh=ivQ/KAyBQUEOMfURrA18XrL8fY1xYwtm3ds/9scBOig=; b=cIOkm0pc2dhkTfD6ix8uk0TC4yk/uB+JbnELHIPkcB/EnOFSNYiAJMAvs88frL3BsQ/ZTp1VIXrmTqtwvWeRPOz04m2g5QHNe04RESk+8NGf9dagf6/of1gzijSrPsPrCrfP1AasYrHEk9S/Q2reDhbd/4D1osX6H/Ijc9UI712Gzlifzt6sGoVn7ZEybjR93bIpMV0h5KGx/x4Hg1vE7hkf7lOBUhaXkZkO+JWLuPCPB3L2y0MUuiGdCBsZObiVBcuqrAPGo80atk9IwABZnUyQVabXdRGbAQ0NMGus6232z+VD2T0diK2fbY/BtcdA5k+JUZOK4XeXexhk/wVkBQ==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tuh6I-0006ED-OM for guix-patches@gnu.org; Tue, 18 Mar 2025 20:16:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#77106] [PATCH 1/1] gnu: Add autofs-service-type. References: <20250319001421.14954-1-ian@retrospec.tv> In-Reply-To: <20250319001421.14954-1-ian@retrospec.tv> Resent-From: Ian Eure Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Wed, 19 Mar 2025 00:16:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 77106 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 77106@debbugs.gnu.org Cc: Ian Eure Received: via spool by 77106-submit@debbugs.gnu.org id=B77106.174234335623868 (code B ref 77106); Wed, 19 Mar 2025 00:16:02 +0000 Received: (at 77106) by debbugs.gnu.org; 19 Mar 2025 00:15:56 +0000 Received: from localhost ([127.0.0.1]:43941 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tuh67-0006CI-F9 for submit@debbugs.gnu.org; Tue, 18 Mar 2025 20:15:55 -0400 Received: from fout-a8-smtp.messagingengine.com ([103.168.172.151]:60273) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1tuh62-0006Ag-6H for 77106@debbugs.gnu.org; Tue, 18 Mar 2025 20:15:49 -0400 Received: from phl-compute-07.internal (phl-compute-07.phl.internal [10.202.2.47]) by mailfout.phl.internal (Postfix) with ESMTP id E3DE013833D7; Tue, 18 Mar 2025 20:15:40 -0400 (EDT) Received: from phl-mailfrontend-02 ([10.202.2.163]) by phl-compute-07.internal (MEProxy); Tue, 18 Mar 2025 20:15:40 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=retrospec.tv; h= cc:cc:content-transfer-encoding:content-type:content-type:date :date:from:from:in-reply-to:message-id:mime-version:reply-to :subject:subject:to:to; s=fm3; t=1742343340; x=1742429740; bh=iv Q/KAyBQUEOMfURrA18XrL8fY1xYwtm3ds/9scBOig=; b=ZvKLG6vNBTuF0gFzBX fD9P2JpB/hnmTdkQyjmTiU8sSXeK5+c39lIeV3ToyrpF/yP+MIPc7JuM286xKHvZ yW+1k54u3Rq/wXMIh6agnrl1oPRN/LeJGun2DqJ08txTSQO/sslDayQHHEgEtVUC 4PR8X8NRLhCnPLBiRcO7l41d5abDHAkRs6rrvuMi+Zflk8sVJnjHAmEu1OqdIUTq 9HjehqMgb6B4qHAfPIjMkZtkY958KlzlraPdTVA+4TLIOf1SSU/BqSqr5OM+yXwR AmtcItvqaQUZW57hvItOYZNIEHq1596L/duBhWw2XZbmVMMAQb1/xJkL8y9B7llQ LVww== DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d= messagingengine.com; h=cc:cc:content-transfer-encoding :content-type:content-type:date:date:feedback-id:feedback-id :from:from:in-reply-to:message-id:mime-version:reply-to:subject :subject:to:to:x-me-proxy:x-me-sender:x-me-sender:x-sasl-enc; s= fm1; t=1742343340; x=1742429740; bh=ivQ/KAyBQUEOMfURrA18XrL8fY1x Ywtm3ds/9scBOig=; b=UfKb0cn57QOdQpPJFTq1WqJWJRvZPy0rx1vBiLVozcqh ku+UbY6O4yszdXj+M4ycRMcFf8RqkMlcbTHcZuiGmQtM4T47EymBc3gc9xkQgqv5 AAQTGGugiM5Fte61pDdF82QHZSlpWP7m3nqThiZFFKSC7dgMeD0iUVNTEPkiBupe TM+Kl7OtCzAJ4JlaBy9lU032u5pSQYgkcBF5tMRZryv1R6oTPm5LZwJgQ5UX/mat 0YUn6d3lvXbwMm19U6h7qDGYJW1g0eag8Flb7Dxoe28sPnyOUmOIyHMCYye4r3M7 RKjSKygHEptd7B04aDn2eY/sqm47GxVtG23Ua+yJnw== X-ME-Sender: X-ME-Received: X-ME-Proxy-Cause: gggruggvucftvghtrhhoucdtuddrgeefvddrtddtgddugeefkeeiucetufdoteggodetrf dotffvucfrrhhofhhilhgvmecuhfgrshhtofgrihhlpdggtfgfnhhsuhgsshgtrhhisggv pdfurfetoffkrfgpnffqhgenuceurghilhhouhhtmecufedttdenucenucfjughrpefhvf evufffkffogggtgfesthekredtredtjeenucfhrhhomhepkfgrnhcugfhurhgvuceoihgr nhesrhgvthhrohhsphgvtgdrthhvqeenucggtffrrghtthgvrhhnpeejuefghefgffefte ehvddtuddutefhvddtfeduhfdugfdvvdeulefgfefhhefhheenucffohhmrghinhepghhn uhdrohhrghenucevlhhushhtvghrufhiiigvpedtnecurfgrrhgrmhepmhgrihhlfhhroh hmpehirghnsehrvghtrhhoshhpvggtrdhtvhdpnhgspghrtghpthhtohepvddpmhhouggv pehsmhhtphhouhhtpdhrtghpthhtohepjeejuddtieesuggvsggsuhhgshdrghhnuhdroh hrghdprhgtphhtthhopehirghnsehrvghtrhhoshhpvggtrdhtvh X-ME-Proxy: Feedback-ID: id9014242:Fastmail Received: by mail.messagingengine.com (Postfix) with ESMTPA; Tue, 18 Mar 2025 20:15:40 -0400 (EDT) From: Ian Eure Date: Tue, 18 Mar 2025 17:15:32 -0700 Message-ID: <20250319001533.14995-1-ian@retrospec.tv> X-Mailer: git-send-email 2.48.1 MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * gnu/services/nfs.scm (autofs-service-type): New variable. (): New record. (): New record. (): 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 ;;; Copyright © 2018, 2019, 2020 Ricardo Wurmus ;;; Copyright © 2020, 2021 Maxim Cournoyer +;;; Copyright © 2023-2025 Ian Eure ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,16 +20,21 @@ ;;; along with GNU Guix. If not, see . (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 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))))