diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/services/pam-mount.scm | 114 |
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."))) |