Merge branch 'master' into emacs-team

1 files changed, 113 insertions, 1 deletions

diff --git a/gnu/services/pam-mount.scm b/gnu/services/pam-mount.scm
index 21c34ddd61..dbb9d0285f 100644
--- a/gnu/services/pam-mount.scm
+++ b/gnu/services/pam-mount.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
+;;; Copyright © 2023 Brian Cully <bjc@spork.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,9 +24,15 @@
   #:use-module (gnu system pam)
   #:use-module (guix gexp)
   #:use-module (guix records)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:export (pam-mount-configuration
             pam-mount-configuration?
-            pam-mount-service-type))
+            pam-mount-service-type
+
+            pam-mount-volume
+            pam-mount-volume?
+            pam-mount-volume-service-type))
 
 (define %pam-mount-default-configuration
   `((debug (@ (enable "0")))
@@ -102,6 +109,11 @@
                              (list optional-pam-mount))))
            pam))))))
 
+(define (extend-pam-mount-configuration initial extensions)
+  "Extends INITIAL with EXTENSIONS."
+  (pam-mount-configuration (rules (append (pam-mount-configuration-rules
+                                           initial) extensions))))
+
 (define pam-mount-service-type
   (service-type
    (name 'pam-mount)
@@ -109,6 +121,106 @@
                                         pam-mount-etc-service)
                      (service-extension pam-root-service-type
                                         pam-mount-pam-service)))
+   (compose concatenate)
+   (extend extend-pam-mount-configuration)
    (default-value (pam-mount-configuration))
    (description "Activate PAM-Mount support.  It allows mounting volumes for
 specific users when they log in.")))
+
+(define (field-name->tag field-name)
+  "Convert FIELD-NAME to its tag used by the configuration XML."
+  (match field-name
+    ('user-name 'user)
+    ('user-id 'uid)
+    ('primary-group 'pgrp)
+    ('group-id 'gid)
+    ('secondary-group 'sgrp)
+    ('file-system-type 'fstype)
+    ('no-mount-as-root? 'noroot)
+    ('file-name 'path)
+    ('mount-point 'mountpoint)
+    ('ssh? 'ssh)
+    ('file-system-key-cipher 'fskeycipher)
+    ('file-system-key-hash 'fskeyhash)
+    ('file-system-key-file-name 'fskeypath)
+    (_ field-name)))
+
+(define-maybe string)
+
+(define (serialize-string field-name value)
+  (list (field-name->tag field-name) value))
+
+(define (integer-or-range? value)
+  (match value
+    ((start . end) (and (integer? start)
+                        (integer? end)))
+    (_ (number? value))))
+
+(define-maybe integer-or-range)
+
+(define (serialize-integer-or-range field-name value)
+  (let ((value-string (match value
+                        ((start . end) (format #f "~a-~a" start end))
+                        (_ (number->string value)))))
+    (list (field-name->tag field-name) value-string)))
+
+(define-maybe boolean)
+
+(define (serialize-boolean field-name value)
+  (let ((value-string (if value "1" "0")))
+    (list (field-name->tag field-name) value-string)))
+
+(define-configuration pam-mount-volume
+  (user-name maybe-string "User name to match.")
+  (user-id maybe-integer-or-range
+   "User ID, or range of user IDs, in the form of @code{(start . end)} to\nmatch.")
+  (primary-group maybe-string "Primary group name to match.")
+  (group-id maybe-integer-or-range
+   "Group ID, or range of group IDs, in the form of @code{(start . end)} to\nmatch.")
+  (secondary-group maybe-string
+   "Match users who belong to this group name as either a primary or secondary\ngroup.")
+  (file-system-type maybe-string "File system type of volume being mounted.")
+  (no-mount-as-root? maybe-boolean
+                     "Do not use super user privileges to mount this volume.")
+  (server maybe-string "Remote server this volume resides on.")
+  (file-name maybe-string "Location of the volume to be mounted.")
+  (mount-point maybe-string
+               "Where to mount the volume in the local file system.")
+  (options maybe-string "Options to pass to the underlying mount program.")
+  (ssh? maybe-boolean "Whether to pass the login password to SSH.")
+  (cipher maybe-string "Cryptsetup cipher named used by volume.")
+  (file-system-key-cipher maybe-string
+                          "Cipher name used by the target volume.")
+  (file-system-key-hash maybe-string
+                        "SSL hash name used by the target volume.")
+  (file-system-key-file-name maybe-string
+   "File name for the file system key used by the target volume."))
+
+(define (pam-mount-volume->sxml volume)
+  ;; Convert a list of configuration fields into an SXML-compatible attribute
+  ;; list.
+  (define xml-attrs
+    (filter-map (lambda (field)
+                  (let* ((accessor (configuration-field-getter field))
+                         (value (accessor volume)))
+                    (and (not (eq? value %unset-value))
+                         (list (field-name->tag (configuration-field-name
+                                                 field)) value))))
+                pam-mount-volume-fields))
+
+  `(volume (@ ,@xml-attrs)))
+
+(define (pam-mount-volume-rules volumes)
+  (map pam-mount-volume->sxml volumes))
+
+(define pam-mount-volume-service-type
+  (service-type (name 'pam-mount-volume)
+                (extensions (list (service-extension pam-mount-service-type
+                                                     pam-mount-volume-rules)))
+                (compose concatenate)
+                (extend append)
+                (default-value '())
+                (description
+                 "Mount remote volumes such as CIFS shares @i{via}
+@acronym{PAM, Pluggable Authentication Modules} when logging in, using login
+credentials.")))