[bug#72316] [PATCH 3/3] Add a guile-pam-module service.

[Felix Lechner]

Change-Id: I1da0fe25f542cf9d8c22d26a7434f952585119e6
---
 doc/guix.texi        |  89 ++++++++++++++++++++++++++++++++++++
 gnu/local.mk         |   1 +
 gnu/services/pam.scm | 105 +++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 195 insertions(+)
 create mode 100644 gnu/services/pam.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 41814042f5..a9bf00f0bb 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -403,6 +403,7 @@ Top
 * Telephony Services::          Telephony services.
 * File-Sharing Services::       File-sharing services.
 * Monitoring Services::         Monitoring services.
+* Guile-PAM Services::          Guile-PAM services.
 * Kerberos Services::           Kerberos services.
 * LDAP Services::               LDAP services.
 * Web Services::                Web servers.
@@ -18991,6 +18992,7 @@ Services
 * Telephony Services::          Telephony services.
 * File-Sharing Services::       File-sharing services.
 * Monitoring Services::         Monitoring services.
+* Guile-PAM Services::          Guile-PAM services.
 * Kerberos Services::           Kerberos services.
 * LDAP Services::               LDAP services.
 * Web Services::                Web servers.
@@ -30932,6 +30934,93 @@ Monitoring Services
 @end deftp
 
 
+@c %end of fragment
+
+@node Guile-PAM Services
+@subsection Guile-PAM Services
+@cindex Guile-PAM
+
+The @code{(gnu services pam)} module provides services related to the
+authentication mechanism @dfn{Guile-PAM}.
+
+Guile-PAM is a reimplementation in GNU Guile of the venerable Linux-PAM
+authentication system.  For details, please have a look at the Texinfo
+manual in the @code{guile-pam} package.
+
+@defvar guile-pam-module-service-type
+A service type for Guile-PAM modules.
+@end defvar
+
+@noindent
+Here is an example of its use:
+@lisp
+(define welcome-pamda-file
+  (scheme-file
+   "welcome-pamda-file"
+   #~(begin
+       (use-modules (ice-9 format))
+
+       (lambda (action handle flags options)
+         (case action
+           ;; authentication management
+           ((pam_sm_authenticate)
+            (format #t "In a working module, we would now identify you.~%"))
+           ((pam_sm_setcred)
+            (format #t "In a working module, we would now help you manage 
additional credentials.~%"))
+           ;; account management
+           ((pam_sm_acct_mgmt)
+            (format #t "In a working module, we would now confirm your access 
rights.~%"))
+           ;; password management
+           ((pam_sm_chauthtok)
+            (format #t "In a working module, we would now change your 
password.~%"))
+           ;; session management
+           ((pam_sm_open_session)
+            (format #t "In a working module, we would now open a session for 
you.~%"))
+           ((pam_sm_close_session)
+            (format #t "In a working module, we would now close your 
session.~%"))
+           (else
+            (format #t "In a working module, we would not know what to do 
about action '~s'.~%"
+                    action)))
+         'PAM_SUCCESS))))
+
+(service guile-pam-module-service-type
+         (guile-pam-module-configuration
+          (rules "optional")
+          (module welcome-pamda-file)
+          (services '("login"
+                      "greetd"
+                      "su"
+                      "slim"
+                      "gdm-password"
+                      "sddm"))))
+@end lisp
+
+@c %start of fragment
+
+@deftp {Data Type} guile-pam-module-configuration
+Available @code{guile-pam-module-configuration} fields are:
+
+@table @asis
+@item @code{rules} (type: maybe-string)
+Determines how the module's return value is evaluated.
+
+@item @code{module} (type: maybe-file-like)
+A Guile-PAM pamda file or a classical PAM module.
+
+@item @code{services} (type: maybe-list-of-strings)
+List of PAM service names for which to install the module.
+
+@item @code{guile-inputs} (type: maybe-list-of-packages)
+Guile inputs available in the PAM module
+
+@item @code{foreign-library-path} (type: maybe-list-of-packages)
+Search path for shared objects and libraries.
+
+@end table
+
+@end deftp
+
+
 @c %end of fragment
 
 @node Kerberos Services
diff --git a/gnu/local.mk b/gnu/local.mk
index fac7b5973b..30551971ac 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -733,6 +733,7 @@ GNU_SYSTEM_MODULES =                                \
   %D%/services/networking.scm                  \
   %D%/services/nix.scm                         \
   %D%/services/nfs.scm                 \
+  %D%/services/pam.scm                         \
   %D%/services/pam-mount.scm                   \
   %D%/services/science.scm                     \
   %D%/services/security.scm                    \
diff --git a/gnu/services/pam.scm b/gnu/services/pam.scm
new file mode 100644
index 0000000000..a242067e38
--- /dev/null
+++ b/gnu/services/pam.scm
@@ -0,0 +1,105 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Felix Lechner <felix.lechner@lease-up.com>
+;;;
+;;; 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 (gnu services pam)
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages guile-xyz)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages mes)
+  #:use-module (gnu services)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu system pam)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (guix utils)
+  #:use-module (srfi srfi-1)
+  #:export (guile-pam-module-configuration))
+
+(define-maybe string)
+(define-maybe list-of-strings)
+(define-maybe file-like)
+
+(define-maybe string-or-file-like)
+(define (string-or-file-like? val)
+  (or (string? val) (file-like? val)))
+
+(define-maybe list-of-packages)
+(define (list-of-packages? val)
+  (and (list? val) (map package? val)))
+
+(define-configuration/no-serialization guile-pam-module-configuration
+  (rules
+   maybe-string
+   "Determines how the module's return value is evaluated.")
+  (module
+   maybe-file-like
+   "A Guile-PAM pamda file or a classical PAM module.")
+  (services
+   maybe-list-of-strings
+   "List of PAM service names for which to install the module.")
+  (guile-inputs
+   maybe-list-of-packages
+   "Guile inputs available in the PAM module")
+  (foreign-library-path
+   maybe-list-of-packages
+   "Search path for shared objects and libraries.") )
+
+(define (guile-pam-module-service config)
+  "Return a list of <shepherd-service> for guile-pam-module for CONFIG."
+  (match-record
+      config <guile-pam-module-configuration> (foreign-library-path
+                                               guile-inputs
+                                               module
+                                               rules
+                                               services)
+      (list
+       (pam-extension
+        (transformer
+         (lambda (pam)
+           (if (member (pam-service-name pam) services)
+               (let* ((new-entry
+                       (pam-entry
+                        (control rules)
+                        (module module)
+                        (guile-inputs (if (eq? %unset-value guile-inputs)
+                                          '()
+                                          guile-inputs))
+                        (foreign-library-path (if (eq? %unset-value 
foreign-library-path)
+                                                  '()
+                                                  foreign-library-path)))))
+                 (pam-service
+                  (inherit pam)
+                  (auth (append (pam-service-auth pam)
+                                (list new-entry)))
+                  (account (append (pam-service-account pam)
+                                   (list new-entry)))
+                  (session (append (pam-service-session pam)
+                                   (list new-entry)))
+                  (password (append (pam-service-password pam)
+                                    (list new-entry)))))
+               pam)))))))
+
+(define-public guile-pam-module-service-type
+  (service-type
+   (name 'guile-pam-module)
+   (extensions (list (service-extension pam-root-service-type
+                                        guile-pam-module-service)))
+   (compose concatenate)
+   (default-value (guile-pam-module-configuration))
+   (description "Load Guile code as part of Linux-PAM.")))
-- 
2.45.2