* [bug#62699] [PATCH] services: add pam-mount-volume-service-type @ 2023-04-06 16:43 Brian Cully via Guix-patches via 2023-04-06 16:57 ` [bug#62699] [PATCH] services: pam-mount: " Brian Cully via Guix-patches via 0 siblings, 1 reply; 7+ messages in thread From: Brian Cully via Guix-patches via @ 2023-04-06 16:43 UTC (permalink / raw) To: 62699 This patch allows adding additional volumes to be mounted at login time via PAM by way of ‘pam-mount-volume-service-type’. As an example usage, I use it to mount a CIFS share which requires authentication automatically on login without having to type my password twice (since my local system has the same username and password as the system hosting my CIFS share). -bjc ^ permalink raw reply [flat|nested] 7+ messages in thread
* [bug#62699] [PATCH] services: pam-mount: add pam-mount-volume-service-type 2023-04-06 16:43 [bug#62699] [PATCH] services: add pam-mount-volume-service-type Brian Cully via Guix-patches via @ 2023-04-06 16:57 ` Brian Cully via Guix-patches via 2023-06-18 21:20 ` [bug#62699] [PATCH] services: " Ludovic Courtès 0 siblings, 1 reply; 7+ messages in thread From: Brian Cully via Guix-patches via @ 2023-04-06 16:57 UTC (permalink / raw) To: 62699; +Cc: Brian Cully, glv 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 (extend-pam-mount-configuration): new procedure (pam-mount-service-type): allow extension by other service-types (field-name->tag): new procedure (serialize-string): new procedure (integer-or-range?): new procedure (serialize-integer-or-range): new procedure (serialize-boolean): new procedure (pam-mount-volume): new configuration (pam-mount-volume->sxml): new procedure (pam-mount-volume-rules): new procedure (pam-mount-volume-service-type): new procedure * Makefile.am: add pam-mount tests * tests/services/pam-mount.scm: new tests --- Makefile.am | 1 + doc/guix.texi | 99 +++++++++++++++++++++++++++++++ gnu/services/pam-mount.scm | 111 ++++++++++++++++++++++++++++++++++- tests/services/pam-mount.scm | 83 ++++++++++++++++++++++++++ 4 files changed, 293 insertions(+), 1 deletion(-) create mode 100644 tests/services/pam-mount.scm diff --git a/Makefile.am b/Makefile.am index 23b939b674..603fa7241f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -548,6 +548,7 @@ SCM_TESTS = \ tests/services/configuration.scm \ tests/services/lightdm.scm \ tests/services/linux.scm \ + tests/services/pam-mount.scm \ tests/services/telephony.scm \ tests/sets.scm \ tests/size.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 4f72e2f34a..d45df03f57 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -114,6 +114,7 @@ Copyright @copyright{} 2023 Giacomo Leidi@* Copyright @copyright{} 2022 Antero Mejr@* Copyright @copyright{} 2023 Karl Hallsby +Copyright @copyright{} 2023 Brian Cully Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -37010,6 +37011,104 @@ PAM Mount Service @end table @end deftp +@subheading PAM Mount Volume Service +@cindex pam volume mounting + +PAM mount volumes are automatically mounted at login by the PAM login +service according to a set of per-volume rules. Because they are +mounted by PAM the password entered during login may be used directly to +mount authenticated volumes, such as @code{cifs}, using the same +credentials. + +These volumes will be added in addition to any volumes directly +specified in @code{pam-mount-rules}. + +Here is an example of a rule which will mount a remote CIFS share from +@file{//remote-server/share} into a sub-directory of @file{/shares} +named after the user logging in: + +@lisp +(simple-service 'pam-mount-remote-share pam-mount-volume-service-type + (list (pam-mount-volume + (secondary-group "users") + (file-system-type "cifs") + (server "remote-server") + (file-name "share") + (mount-point "/shares/%(USER)") + (options "nosuid,nodev,seal,cifsacl")))) +@end lisp + +@deftp {Data Type} pam-mount-volume-service-type +Configuration for a single volume to be mounted. Any fields not +specified will be omitted from the run-time PAM configuration. See +@uref{http://pam-mount.sourceforge.net/pam_mount.conf.5.html, +the man page} for the default values when unspecified. + +@table @asis +@item @code{user-name} (type: maybe-string) +Mount the volume for the given user. + +@item @code{user-id} (type: maybe-integer-or-range) +Mount the volume for the user with this ID. This field may also be +specified as a cons cell of @code{(start . end)} indicating a range of +user IDs for whom to mount the volume. + +@item @code{primary-group} (type: maybe-string) +Mount the volume for users with this primary group name. + +@item @code{group-id} (type: maybe-integer-or-range) +Mount the volume for the users with this primary group ID. This field +may also be specified as a cons cell of @code{(start . end)} indicating +a range of group ids for whom to mount the volume. + +@item @code{secondary-group} (type: maybe-string) +Mount the volume for users who are members of this group as either a +primary or secondary group. + +@item @code{file-system-type} (type: maybe-string) +The file system type for the volume being mounted (e.g., @code{cifs}) + +@item @code{no-mount-as-root?} (type: maybe-boolean) +Whether or not to mount the volume with root privileges. This is +normally disabled, but may be enabled for mounts of type @code{fuse}, or +other user-level mounts. + +@item @code{server} (type: maybe-string) +The name of the remote server to mount the volume from, when necessary. + +@item @code{file-name} (type: maybe-string) +The location of the volume, either local or remote, depending on the +@code{file-system-type}. + +@item @code{mount-point} (type: maybe-string) +Where to mount the volume in the local file-system. This may be set to +@file{~} to indicate the home directory of the user logging in. If this +field is omitted then @file{/etc/fstab} is consulted for the mount +destination. + +@item @code{options} (type: maybe-string) +The options to be passed as-is to the underlying mount program. + +@item @code{ssh?} (type: maybe-boolean) +Enable this option to pass the login password to SSH for use with mounts +involving SSH (e.g., @code{sshfs}). + +@item @code{cipher} (type: maybe-string) +Cryptsetup cipher name for the volume. To be used with the @code{crypt} +@code{file-system-type}. + +@item @code{file-system-key-cipher} (type: maybe-string) +Cipher name used by the target volume. + +@item @code{file-system-key-hash} (type: maybe-string) +SSL hash name used by the target volume. + +@item @code{file-system-key-file-name} (type: maybe-string) +File name of the file system key for the target volume. + +@end table +@end deftp + @node Guix Services @subsection Guix Services diff --git a/gnu/services/pam-mount.scm b/gnu/services/pam-mount.scm index e60781d05b..3014af8896 100644 --- a/gnu/services/pam-mount.scm +++ b/gnu/services/pam-mount.scm @@ -23,9 +23,15 @@ (define-module (gnu services pam-mount) #: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"))) @@ -99,6 +105,11 @@ (define (pam-mount-pam-service config) (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) @@ -106,6 +117,104 @@ (define pam-mount-service-type 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 + "Volumes to be mounted during PAM-assisted login."))) diff --git a/tests/services/pam-mount.scm b/tests/services/pam-mount.scm new file mode 100644 index 0000000000..bfbd15967f --- /dev/null +++ b/tests/services/pam-mount.scm @@ -0,0 +1,83 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Brian Cully <bjc@spork.org> +;;; +;;; 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 (tests services pam-mount) + #:use-module (gnu services pam-mount) + #:use-module (gnu system pam) + #:use-module (gnu services) + #:use-module (gnu services configuration) + #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix grafts) + #:use-module (guix store) + #:use-module (guix tests) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(define pam-mount-volume-fields (@@ (gnu services pam-mount) + pam-mount-volume-fields)) +(define field-name->tag (@@ (gnu services pam-mount) + field-name->tag)) + +(define pam-mount-volume->sxml (@@ (gnu services pam-mount) + pam-mount-volume->sxml)) + +(test-begin "services-pam-mount") + +(test-group "field-name->tag" + (let ((field-map '((user-name user) + (user-id uid) + (primary-group pgrp) + (group-id gid) + (secondary-group sgrp) + (file-system-type fstype) + (no-mount-as-root? noroot) + (server server) + (file-name path) + (mount-point mountpoint) + (options options) + (ssh? ssh) + (cipher cipher) + (file-system-key-cipher fskeycipher) + (file-system-key-hash fskeyhash) + (file-system-key-file-name fskeypath)))) + + (test-equal "all fields accounted for" + (map car field-map) + (map configuration-field-name pam-mount-volume-fields)) + + (for-each (match-lambda + ((field-name tag-name) + (test-eq (format #f "~a -> ~a" field-name tag-name) + (field-name->tag field-name) tag-name))) + field-map))) + +(let ((tmpfs-volume (pam-mount-volume + (secondary-group "users") + (file-system-type "tmpfs") + (mount-point "/run/user/%(USERUID)") + (options "someoptions")))) + (test-equal "tmpfs" + '(volume (@ (sgrp "users") + (fstype "tmpfs") + (mountpoint "/run/user/%(USERUID)") + (options "someoptions"))) + (pam-mount-volume->sxml tmpfs-volume))) + +(test-end "services-pam-mount") -- 2.39.2 ^ permalink raw reply related [flat|nested] 7+ messages in thread
* [bug#62699] [PATCH] services: add pam-mount-volume-service-type 2023-04-06 16:57 ` [bug#62699] [PATCH] services: pam-mount: " Brian Cully via Guix-patches via @ 2023-06-18 21:20 ` Ludovic Courtès 2023-06-20 14:14 ` Brian Cully via Guix-patches via 0 siblings, 1 reply; 7+ messages in thread From: Ludovic Courtès @ 2023-06-18 21:20 UTC (permalink / raw) To: Brian Cully; +Cc: glv, 62699 Hi! Brian Cully <bjc@spork.org> skribis: > 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 (extend-pam-mount-configuration): new procedure > (pam-mount-service-type): allow extension by other service-types > (field-name->tag): new procedure > (serialize-string): new procedure > (integer-or-range?): new procedure > (serialize-integer-or-range): new procedure > (serialize-boolean): new procedure > (pam-mount-volume): new configuration > (pam-mount-volume->sxml): new procedure > (pam-mount-volume-rules): new procedure > (pam-mount-volume-service-type): new procedure > * Makefile.am: add pam-mount tests > * tests/services/pam-mount.scm: new tests This looks useful! Nitpick: for new files like ‘pam-mount.scm’ in this case, it’s enough to write “New file” (relief :-)). I’ve never used PAM mount before so I can only comment on the implementation and doc (maybe Guillaume is more familiar with it?). > Copyright @copyright{} 2022 Antero Mejr@* > Copyright @copyright{} 2023 Karl Hallsby > +Copyright @copyright{} 2023 Brian Cully Please add @* on the previous line to insert a line break. > +@item @code{user-id} (type: maybe-integer-or-range) > +Mount the volume for the user with this ID. This field may also be > +specified as a cons cell of @code{(start . end)} indicating a range of Use the term “pair” rather than “cons cell” (throughout the section), for consistency with the rest of the manual and to make it more approachable. > +(test-end "services-pam-mount") Neat. How hard would it be to also have a system tests under (gnu tests …)? Seems like it would better cover functionality. Thanks! Ludo’. ^ permalink raw reply [flat|nested] 7+ messages in thread
* [bug#62699] [PATCH] services: add pam-mount-volume-service-type 2023-06-18 21:20 ` [bug#62699] [PATCH] services: " Ludovic Courtès @ 2023-06-20 14:14 ` Brian Cully via Guix-patches via 2023-07-18 14:01 ` Brian Cully via Guix-patches via 0 siblings, 1 reply; 7+ messages in thread From: Brian Cully via Guix-patches via @ 2023-06-20 14:14 UTC (permalink / raw) To: Ludovic Courtès; +Cc: glv, 62699 Ludovic Courtès <ludo@gnu.org> writes: > Nitpick: for new files like ‘pam-mount.scm’ in this case, it’s > enough to > write “New file” (relief :-)). Fixed. > Please add @* on the previous line to insert a line break. Fixed. FWIW, I tried looking through the manual (both Guix' and TexInfo's) to see what this sigil meant, I couldn't figure it out, so I just guessed. Is this documented somewhere? > Use the term “pair” rather than “cons cell” (throughout the > section), > for consistency with the rest of the manual and to make it more > approachable. Fixed. > How hard would it be to also have a system tests under (gnu > tests …)? > Seems like it would better cover functionality. I'm not sure. I've never done integration tests on an entire operating system before, so it'd take some doing just to learn the ropes. I'll go through the existing tests and see what I can come up with. Would it be okay to do that as a separate patch, though? Given how long I expect this work to take, I would like to avoid that extra delay in having the current patch set (plus the above changes) committed. -bjc ^ permalink raw reply [flat|nested] 7+ messages in thread
* [bug#62699] [PATCH] services: add pam-mount-volume-service-type 2023-06-20 14:14 ` Brian Cully via Guix-patches via @ 2023-07-18 14:01 ` Brian Cully via Guix-patches via 2023-07-18 14:06 ` [bug#62699] [PATCH v2] " Brian Cully via Guix-patches via 0 siblings, 1 reply; 7+ messages in thread From: Brian Cully via Guix-patches via @ 2023-07-18 14:01 UTC (permalink / raw) To: Ludovic Courtès; +Cc: glv, 62699 This patch lacks integration tests, but otherwise should be complete. I did spend some time trying to figure out how to set up the integration tests, but it's quite complex for this case and I'd rather not hold this up until they're done. I'd like to submit them separately when I can dedicate more time to their creation. -bjc ^ permalink raw reply [flat|nested] 7+ messages in thread
* [bug#62699] [PATCH v2] services: add pam-mount-volume-service-type 2023-07-18 14:01 ` Brian Cully via Guix-patches via @ 2023-07-18 14:06 ` Brian Cully via Guix-patches via 2023-08-09 10:30 ` bug#62699: " Ludovic Courtès 0 siblings, 1 reply; 7+ messages in thread From: Brian Cully via Guix-patches via @ 2023-07-18 14:06 UTC (permalink / raw) To: Ludovic Courtès; +Cc: glv, 62699 [-- Attachment #1: v2-0001-services-pam-mount-add-pam-mount-volume-service-t.patch --] [-- Type: text/x-patch, Size: 15026 bytes --] 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 --- Makefile.am | 1 + doc/guix.texi | 99 +++++++++++++++++++++++++++++++ gnu/services/pam-mount.scm | 111 ++++++++++++++++++++++++++++++++++- tests/services/pam-mount.scm | 83 ++++++++++++++++++++++++++ 4 files changed, 293 insertions(+), 1 deletion(-) create mode 100644 tests/services/pam-mount.scm diff --git a/Makefile.am b/Makefile.am index d680c8c76c..de239d7fca 100644 --- a/Makefile.am +++ b/Makefile.am @@ -557,6 +557,7 @@ SCM_TESTS = \ tests/services/configuration.scm \ tests/services/lightdm.scm \ tests/services/linux.scm \ + tests/services/pam-mount.scm \ tests/services/telephony.scm \ tests/sets.scm \ tests/size.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index ee03de04dc..2c1ac6d090 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -116,6 +116,7 @@ Copyright @copyright{} 2023 Karl Hallsby@* Copyright @copyright{} 2023 Nathaniel Nicandro@* Copyright @copyright{} 2023 Tanguy Le Carrour@* +Copyright @copyright{} 2023 Brian Cully@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -37752,6 +37753,104 @@ PAM Mount Service @end table @end deftp +@subheading PAM Mount Volume Service +@cindex pam volume mounting + +PAM mount volumes are automatically mounted at login by the PAM login +service according to a set of per-volume rules. Because they are +mounted by PAM the password entered during login may be used directly to +mount authenticated volumes, such as @code{cifs}, using the same +credentials. + +These volumes will be added in addition to any volumes directly +specified in @code{pam-mount-rules}. + +Here is an example of a rule which will mount a remote CIFS share from +@file{//remote-server/share} into a sub-directory of @file{/shares} +named after the user logging in: + +@lisp +(simple-service 'pam-mount-remote-share pam-mount-volume-service-type + (list (pam-mount-volume + (secondary-group "users") + (file-system-type "cifs") + (server "remote-server") + (file-name "share") + (mount-point "/shares/%(USER)") + (options "nosuid,nodev,seal,cifsacl")))) +@end lisp + +@deftp {Data Type} pam-mount-volume-service-type +Configuration for a single volume to be mounted. Any fields not +specified will be omitted from the run-time PAM configuration. See +@uref{http://pam-mount.sourceforge.net/pam_mount.conf.5.html, +the man page} for the default values when unspecified. + +@table @asis +@item @code{user-name} (type: maybe-string) +Mount the volume for the given user. + +@item @code{user-id} (type: maybe-integer-or-range) +Mount the volume for the user with this ID. This field may also be +specified as a pair of @code{(start . end)} indicating a range of user +IDs for whom to mount the volume. + +@item @code{primary-group} (type: maybe-string) +Mount the volume for users with this primary group name. + +@item @code{group-id} (type: maybe-integer-or-range) +Mount the volume for the users with this primary group ID. This field +may also be specified as a cons cell of @code{(start . end)} indicating +a range of group ids for whom to mount the volume. + +@item @code{secondary-group} (type: maybe-string) +Mount the volume for users who are members of this group as either a +primary or secondary group. + +@item @code{file-system-type} (type: maybe-string) +The file system type for the volume being mounted (e.g., @code{cifs}) + +@item @code{no-mount-as-root?} (type: maybe-boolean) +Whether or not to mount the volume with root privileges. This is +normally disabled, but may be enabled for mounts of type @code{fuse}, or +other user-level mounts. + +@item @code{server} (type: maybe-string) +The name of the remote server to mount the volume from, when necessary. + +@item @code{file-name} (type: maybe-string) +The location of the volume, either local or remote, depending on the +@code{file-system-type}. + +@item @code{mount-point} (type: maybe-string) +Where to mount the volume in the local file-system. This may be set to +@file{~} to indicate the home directory of the user logging in. If this +field is omitted then @file{/etc/fstab} is consulted for the mount +destination. + +@item @code{options} (type: maybe-string) +The options to be passed as-is to the underlying mount program. + +@item @code{ssh?} (type: maybe-boolean) +Enable this option to pass the login password to SSH for use with mounts +involving SSH (e.g., @code{sshfs}). + +@item @code{cipher} (type: maybe-string) +Cryptsetup cipher name for the volume. To be used with the @code{crypt} +@code{file-system-type}. + +@item @code{file-system-key-cipher} (type: maybe-string) +Cipher name used by the target volume. + +@item @code{file-system-key-hash} (type: maybe-string) +SSL hash name used by the target volume. + +@item @code{file-system-key-file-name} (type: maybe-string) +File name of the file system key for the target volume. + +@end table +@end deftp + @node Guix Services @subsection Guix Services diff --git a/gnu/services/pam-mount.scm b/gnu/services/pam-mount.scm index 21c34ddd61..8a38d6b1cc 100644 --- a/gnu/services/pam-mount.scm +++ b/gnu/services/pam-mount.scm @@ -23,9 +23,15 @@ (define-module (gnu services pam-mount) #: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 +108,11 @@ (define (pam-mount-pam-service config) (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 +120,104 @@ (define pam-mount-service-type 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 + "Volumes to be mounted during PAM-assisted login."))) diff --git a/tests/services/pam-mount.scm b/tests/services/pam-mount.scm new file mode 100644 index 0000000000..bfbd15967f --- /dev/null +++ b/tests/services/pam-mount.scm @@ -0,0 +1,83 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Brian Cully <bjc@spork.org> +;;; +;;; 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 (tests services pam-mount) + #:use-module (gnu services pam-mount) + #:use-module (gnu system pam) + #:use-module (gnu services) + #:use-module (gnu services configuration) + #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix grafts) + #:use-module (guix store) + #:use-module (guix tests) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(define pam-mount-volume-fields (@@ (gnu services pam-mount) + pam-mount-volume-fields)) +(define field-name->tag (@@ (gnu services pam-mount) + field-name->tag)) + +(define pam-mount-volume->sxml (@@ (gnu services pam-mount) + pam-mount-volume->sxml)) + +(test-begin "services-pam-mount") + +(test-group "field-name->tag" + (let ((field-map '((user-name user) + (user-id uid) + (primary-group pgrp) + (group-id gid) + (secondary-group sgrp) + (file-system-type fstype) + (no-mount-as-root? noroot) + (server server) + (file-name path) + (mount-point mountpoint) + (options options) + (ssh? ssh) + (cipher cipher) + (file-system-key-cipher fskeycipher) + (file-system-key-hash fskeyhash) + (file-system-key-file-name fskeypath)))) + + (test-equal "all fields accounted for" + (map car field-map) + (map configuration-field-name pam-mount-volume-fields)) + + (for-each (match-lambda + ((field-name tag-name) + (test-eq (format #f "~a -> ~a" field-name tag-name) + (field-name->tag field-name) tag-name))) + field-map))) + +(let ((tmpfs-volume (pam-mount-volume + (secondary-group "users") + (file-system-type "tmpfs") + (mount-point "/run/user/%(USERUID)") + (options "someoptions")))) + (test-equal "tmpfs" + '(volume (@ (sgrp "users") + (fstype "tmpfs") + (mountpoint "/run/user/%(USERUID)") + (options "someoptions"))) + (pam-mount-volume->sxml tmpfs-volume))) + +(test-end "services-pam-mount") base-commit: a8c79839d57acf96df720630b8e6ddee8a8c2cf8 -- 2.41.0 ^ permalink raw reply related [flat|nested] 7+ messages in thread
* bug#62699: [PATCH v2] services: add pam-mount-volume-service-type 2023-07-18 14:06 ` [bug#62699] [PATCH v2] " Brian Cully via Guix-patches via @ 2023-08-09 10:30 ` Ludovic Courtès 0 siblings, 0 replies; 7+ messages in thread From: Ludovic Courtès @ 2023-08-09 10:30 UTC (permalink / raw) To: Brian Cully; +Cc: glv, 62699-done [-- Attachment #1: Type: text/plain, Size: 505 bytes --] Hello, Brian Cully <bjc@spork.org> skribis: > 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 Applied with the changes below. Thanks! Ludo’. [-- Attachment #2: Type: text/x-patch, Size: 815 bytes --] diff --git a/gnu/services/pam-mount.scm b/gnu/services/pam-mount.scm index 8a38d6b1cc..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. ;;; @@ -220,4 +221,6 @@ (define pam-mount-volume-service-type (extend append) (default-value '()) (description - "Volumes to be mounted during PAM-assisted login."))) + "Mount remote volumes such as CIFS shares @i{via} +@acronym{PAM, Pluggable Authentication Modules} when logging in, using login +credentials."))) ^ permalink raw reply related [flat|nested] 7+ messages in thread
end of thread, other threads:[~2023-08-09 10:31 UTC | newest] Thread overview: 7+ messages (download: mbox.gz follow: Atom feed -- links below jump to the message on this page -- 2023-04-06 16:43 [bug#62699] [PATCH] services: add pam-mount-volume-service-type Brian Cully via Guix-patches via 2023-04-06 16:57 ` [bug#62699] [PATCH] services: pam-mount: " Brian Cully via Guix-patches via 2023-06-18 21:20 ` [bug#62699] [PATCH] services: " Ludovic Courtès 2023-06-20 14:14 ` Brian Cully via Guix-patches via 2023-07-18 14:01 ` Brian Cully via Guix-patches via 2023-07-18 14:06 ` [bug#62699] [PATCH v2] " Brian Cully via Guix-patches via 2023-08-09 10:30 ` bug#62699: " Ludovic Courtès
Code repositories for project(s) associated with this external index https://git.savannah.gnu.org/cgit/guix.git This is an external index of several public inboxes, see mirroring instructions on how to clone and mirror all data and code used by this external index.