[bug#62699] [PATCH] services: add pam-mount-volume-service-type

[bug#62699] [PATCH] services: add pam-mount-volume-service-type

[Brian Cully via Guix-patches via]

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

[bug#62699] [PATCH] services: pam-mount: add pam-mount-volume-service-type

[Brian Cully via Guix-patches via]

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

[bug#62699] [PATCH] services: add pam-mount-volume-service-type

[Ludovic Courtès]

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’.

[bug#62699] [PATCH] services: add pam-mount-volume-service-type

[Brian Cully via Guix-patches via]

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

[bug#62699] [PATCH] services: add pam-mount-volume-service-type

[Brian Cully via Guix-patches via]

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

[bug#62699] [PATCH v2] services: add pam-mount-volume-service-type

[Brian Cully via Guix-patches via]

[-- 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

bug#62699: [PATCH v2] services: add pam-mount-volume-service-type

[Ludovic Courtès]

[-- 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.")))