summaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
authorBrian Cully <bjc@spork.org>2023-07-18 10:06:16 -0400
committerLudovic Courtès <ludo@gnu.org>2023-08-10 09:26:08 +0200
commit8a88b8b0b5924f8ed00a49e79714cb005cffc7cb (patch)
tree4faf6c0127bb5c17310b9e4c785344ddca0a5145 /gnu/services
parent90e34d25d5e7c14b7f3293a78f3cdad676c0d035 (diff)
services: Add pam-mount-volume-service-type.
The `pam-mount-volumes-service-type' adds additional volumes to the pam-mount-service-type in addition to any that are already specified in `pam-mount-rules'. * doc/guix.texi (PAM Mount Volume Service): add documentation for `pam-mount-service-type'. * gnu/services/pam-mount.scm: new file. * Makefile.am: add pam-mount tests * tests/services/pam-mount.scm: new tests Signed-off-by: Ludovic Courtès <ludo@gnu.org>
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/pam-mount.scm114
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.")))