system: pam: Let PAM extensions add shepherd requirements.

* gnu/system/pam.scm (<pam-extension>): New record type. (pam-shepherd-service): Add Shepherd synchronization point. * gnu/services/mail.scm (dovecot-shepherd-service) * gnu/services/lightdm.scm (lightdm-shepherd-service) * gnu/services/mail.scm (opensmtpd-shepherd-service) * gnu/services/sddm.scm (sddm-shepherd-service) * gnu/services/ssh.scm (lsh-shepherd-service, openssh-shepherd-service) * gnu/services/xorg.scm (slim-shepherd-service, gdm-shepherd-service) * gnu/services/base.scm (greetd-shepherd-services): Add PAM requirement. * gnu/system/pam.scm (/etc-entry, extend-configuration, pam-root-service-type, pam-root-service) * gnu/services/authentication.scm (pam-ldap-pam-service) * gnu/services/base.scm (pam-limits-service-type) (greetd-pam-service) * gnu/services/desktop.scm (pam-gnome-keyring) * gnu/services/kerberos.scm (pam-krb5-pam-service) * gnu/services/pam-mount.scm (pam-mount-pam-service): Adapt to use pam-extension. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
2025-01-19 05:57:04 +01:00 · 2023-05-09 18:45:07 +02:00 · 2023-05-09 18:45:07 +02:00 · 2df5d4fd18
commit 2df5d4fd18
parent b2a65b4c8c
11 changed files with 178 additions and 111 deletions
--- a/gnu/services/authentication.scm
+++ b/gnu/services/authentication.scm
@ -506,19 +506,21 @@ (define (pam-ldap-pam-service config)
  (define pam-ldap-module
    #~(string-append #$(nslcd-configuration-nss-pam-ldapd config)
                     "/lib/security/pam_ldap.so"))
-  (lambda (pam)
-    (if (member (pam-service-name pam)
-                (nslcd-configuration-pam-services config))
-        (let ((sufficient
-               (pam-entry
-                (control "sufficient")
-                (module pam-ldap-module))))
-          (pam-service
-           (inherit pam)
-           (auth (cons sufficient (pam-service-auth pam)))
-           (session (cons sufficient (pam-service-session pam)))
-           (account (cons sufficient (pam-service-account pam)))))
-        pam)))
+  (pam-extension
+    (transformer
+     (lambda (pam)
+       (if (member (pam-service-name pam)
+                   (nslcd-configuration-pam-services config))
+           (let ((sufficient
+                  (pam-entry
+                   (control "sufficient")
+                   (module pam-ldap-module))))
+             (pam-service
+              (inherit pam)
+              (auth (cons sufficient (pam-service-auth pam)))
+              (session (cons sufficient (pam-service-session pam)))
+              (account (cons sufficient (pam-service-account pam)))))
+           pam)))))

 (define (pam-ldap-pam-services config)
  (list (pam-ldap-pam-service config)))
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@ -1603,20 +1603,22 @@ (define-deprecated (syslog-service #:optional (config (syslog-configuration)))

 (define pam-limits-service-type
  (let ((pam-extension
-         (lambda (pam)
-           (let ((pam-limits (pam-entry
-                              (control "required")
-                              (module "pam_limits.so")
-                              (arguments
-                               '("conf=/etc/security/limits.conf")))))
-             (if (member (pam-service-name pam)
-                         '("login" "greetd" "su" "slim" "gdm-password" "sddm"
-                           "sudo" "sshd"))
-                 (pam-service
-                  (inherit pam)
-                  (session (cons pam-limits
-                                 (pam-service-session pam))))
-                 pam))))
+         (pam-extension
+          (transformer
+           (lambda (pam)
+             (let ((pam-limits (pam-entry
+                                (control "required")
+                                (module "pam_limits.so")
+                                (arguments
+                                 '("conf=/etc/security/limits.conf")))))
+               (if (member (pam-service-name pam)
+                           '("login" "greetd" "su" "slim" "gdm-password"
+                             "sddm" "sudo" "sshd"))
+                   (pam-service
+                    (inherit pam)
+                    (session (cons pam-limits
+                                   (pam-service-session pam))))
+                   pam))))))

        ;; XXX: Using file-like objects is deprecated, use lists instead.
        ;;      This is to be reduced into the list? case when the deprecated
@ -3264,16 +3266,18 @@ (module #~(string-append #$greetd-pam-mount "/lib/security/pam_mount.so"))
                     (greetd-allow-empty-passwords? config)
                     #:motd
                     (greetd-motd config))
-   (lambda (pam)
-     (if (member (pam-service-name pam)
-                 '("login" "greetd" "su" "slim" "gdm-password"))
-         (pam-service
-          (inherit pam)
-          (auth (append (pam-service-auth pam)
-                        (list optional-pam-mount)))
-          (session (append (pam-service-session pam)
-                           (list optional-pam-mount))))
-         pam))))
+   (pam-extension
+    (transformer
+     (lambda (pam)
+       (if (member (pam-service-name pam)
+                   '("login" "greetd" "su" "slim" "gdm-password"))
+           (pam-service
+            (inherit pam)
+            (auth (append (pam-service-auth pam)
+                          (list optional-pam-mount)))
+            (session (append (pam-service-session pam)
+                             (list optional-pam-mount))))
+           pam))))))

 (define (greetd-shepherd-services config)
  (map
@ -3285,7 +3289,7 @@ (define (greetd-shepherd-services config)
          (greetd-vt (greetd-terminal-vt tc)))
       (shepherd-service
        (documentation "Minimal and flexible login manager daemon")
-        (requirement '(user-processes host-name udev virtual-terminal))
+        (requirement '(pam user-processes host-name udev virtual-terminal))
        (provision (list (symbol-append
                          'term-tty
                          (string->symbol (greetd-terminal-vt tc)))))
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@ -1187,10 +1187,12 @@ (define pam-elogind
     (module (file-append (elogind-package config)
                          "/lib/security/pam_elogind.so"))))

-  (list (lambda (pam)
-          (pam-service
-           (inherit pam)
-           (session (cons pam-elogind (pam-service-session pam)))))))
+  (list (pam-extension
+         (transformer
+          (lambda (pam)
+            (pam-service
+             (inherit pam)
+             (session (cons pam-elogind (pam-service-session pam)))))))))

 (define (elogind-shepherd-service config)
  "Return a Shepherd service to start elogind according to @var{config}."
@ -1703,22 +1705,24 @@ (module (file-append (gnome-keyring-package config)
     (arguments arguments)))

  (list
-   (lambda (service)
-     (case (assoc-ref (gnome-keyring-pam-services config)
-                      (pam-service-name service))
-       ((login)
-        (pam-service
-         (inherit service)
-         (auth (append (pam-service-auth service)
-                       (list (%pam-keyring-entry))))
-         (session (append (pam-service-session service)
-                          (list (%pam-keyring-entry "auto_start"))))))
-       ((passwd)
-        (pam-service
-         (inherit service)
-         (password (append (pam-service-password service)
-                           (list (%pam-keyring-entry))))))
-       (else service)))))
+   (pam-extension
+    (transformer
+     (lambda (service)
+       (case (assoc-ref (gnome-keyring-pam-services config)
+                        (pam-service-name service))
+         ((login)
+          (pam-service
+           (inherit service)
+           (auth (append (pam-service-auth service)
+                         (list (%pam-keyring-entry))))
+           (session (append (pam-service-session service)
+                            (list (%pam-keyring-entry "auto_start"))))))
+         ((passwd)
+          (pam-service
+           (inherit service)
+           (password (append (pam-service-password service)
+                             (list (%pam-keyring-entry))))))
+         (else service)))))))

 (define gnome-keyring-service-type
  (service-type
--- a/gnu/services/kerberos.scm
+++ b/gnu/services/kerberos.scm
@ -428,27 +428,29 @@ (define-record-type* <pam-krb5-configuration>

 (define (pam-krb5-pam-service config)
  "Return a PAM service for Kerberos authentication."
-  (lambda (pam)
-    (define pam-krb5-module
-      #~(string-append #$(pam-krb5-configuration-pam-krb5 config)
-                       "/lib/security/pam_krb5.so"))
+  (pam-extension
+   (transformer
+    (lambda (pam)
+      (define pam-krb5-module
+        #~(string-append #$(pam-krb5-configuration-pam-krb5 config)
+                         "/lib/security/pam_krb5.so"))

-    (let ((pam-krb5-sufficient
-           (pam-entry
-            (control "sufficient")
-            (module pam-krb5-module)
-            (arguments
-             (list
-              (format #f "minimum_uid=~a"
-                      (pam-krb5-configuration-minimum-uid config)))))))
-      (pam-service
-       (inherit pam)
-       (auth (cons* pam-krb5-sufficient
-                    (pam-service-auth pam)))
-       (session (cons* pam-krb5-sufficient
-                       (pam-service-session pam)))
-       (account (cons* pam-krb5-sufficient
-                       (pam-service-account pam)))))))
+      (let ((pam-krb5-sufficient
+             (pam-entry
+              (control "sufficient")
+              (module pam-krb5-module)
+              (arguments
+               (list
+                (format #f "minimum_uid=~a"
+                        (pam-krb5-configuration-minimum-uid config)))))))
+        (pam-service
+         (inherit pam)
+         (auth (cons* pam-krb5-sufficient
+                      (pam-service-auth pam)))
+         (session (cons* pam-krb5-sufficient
+                         (pam-service-session pam)))
+         (account (cons* pam-krb5-sufficient
+                         (pam-service-account pam)))))))))

 (define (pam-krb5-pam-services config)
  (list (pam-krb5-pam-service config)))
--- a/gnu/services/lightdm.scm
+++ b/gnu/services/lightdm.scm
@ -616,7 +616,7 @@ (define data-dirs
  (list
   (shepherd-service
    (documentation "LightDM display manager")
-    (requirement '(dbus-system user-processes host-name))
+    (requirement '(pam dbus-system user-processes host-name))
    (provision '(lightdm display-manager xorg-server))
    (respawn? #f)
    (start
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@ -1578,7 +1578,7 @@ (define (dovecot-shepherd-service config)
    (list (shepherd-service
           (documentation "Run the Dovecot POP3/IMAP mail server.")
           (provision '(dovecot))
-           (requirement '(networking))
+           (requirement '(pam networking))
           (start #~(make-forkexec-constructor
                     (list (string-append #$dovecot "/sbin/dovecot")
                           "-F")))
@ -1676,7 +1676,7 @@ (define (opensmtpd-shepherd-service config)
                       (package config-file shepherd-requirement)
    (list (shepherd-service
           (provision '(smtpd))
-           (requirement `(loopback ,@shepherd-requirement))
+           (requirement `(pam loopback ,@shepherd-requirement))
           (documentation "Run the OpenSMTPD daemon.")
           (start (let ((smtpd (file-append package "/sbin/smtpd")))
                    #~(make-forkexec-constructor
--- a/gnu/services/pam-mount.scm
+++ b/gnu/services/pam-mount.scm
@ -88,16 +88,19 @@ (define optional-pam-mount
    (pam-entry
     (control "optional")
     (module #~(string-append #$pam-mount "/lib/security/pam_mount.so"))))
-  (list (lambda (pam)
-          (if (member (pam-service-name pam)
-                      '("login" "greetd" "su" "slim" "gdm-password" "sddm"))
-              (pam-service
-               (inherit pam)
-               (auth (append (pam-service-auth pam)
-                             (list optional-pam-mount)))
-               (session (append (pam-service-session pam)
-                                (list optional-pam-mount))))
-              pam))))
+  (list
+   (pam-extension
+    (transformer
+     (lambda (pam)
+       (if (member (pam-service-name pam)
+                   '("login" "greetd" "su" "slim" "gdm-password" "sddm"))
+           (pam-service
+            (inherit pam)
+            (auth (append (pam-service-auth pam)
+                          (list optional-pam-mount)))
+            (session (append (pam-service-session pam)
+                             (list optional-pam-mount))))
+           pam))))))

 (define pam-mount-service-type
  (service-type
--- a/gnu/services/sddm.scm
+++ b/gnu/services/sddm.scm
@ -169,7 +169,7 @@ (define sddm-command

  (list (shepherd-service
         (documentation "SDDM display manager.")
-         (requirement '(user-processes elogind))
+         (requirement '(user-processes elogind pam))
         (provision '(xorg-server display-manager))
         (start #~(make-forkexec-constructor #$sddm-command))
         (stop #~(make-kill-destructor)))))
--- a/gnu/services/ssh.scm
+++ b/gnu/services/ssh.scm
@ -197,9 +197,11 @@ (define lsh-command
                     interfaces)))))

  (define requires
-    (if (and daemonic? (lsh-configuration-syslog-output? config))
-        '(networking syslogd)
-        '(networking)))
+    `(networking
+      pam
+      ,@(if (and daemonic? (lsh-configuration-syslog-output? config))
+            '(syslogd)
+            '())))

  (list (shepherd-service
         (documentation "GNU lsh SSH server")
@ -566,7 +568,7 @@ (define ipv6-support?

  (list (shepherd-service
         (documentation "OpenSSH server.")
-         (requirement '(syslogd loopback))
+         (requirement '(pam syslogd loopback))
         (provision '(ssh-daemon ssh sshd))

         (start #~(if #$inetd-style?
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@ -667,7 +667,7 @@ (define theme

                       (list (symbol-append 'xorg-server-
                                            (string->symbol vt)))))
-           (requirement '(user-processes host-name udev))
+           (requirement '(pam user-processes host-name udev))
           (start
            #~(lambda ()
                ;; A stale lock file can prevent SLiM from starting, so remove it to
@ -1119,7 +1119,7 @@ (define config-file
  (list (shepherd-service
         (documentation "Xorg display server (GDM)")
         (provision '(xorg-server))
-         (requirement '(dbus-system user-processes host-name udev elogind))
+         (requirement '(dbus-system pam user-processes host-name udev elogind))
         (start #~(lambda ()
                    (fork+exec-command
                     (list #$(file-append (gdm-configuration-gdm config)
--- a/gnu/system/pam.scm
+++ b/gnu/system/pam.scm
@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013-2017, 2019-2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023 Josselin Poiret <dev@jpoiret.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@ -19,8 +20,11 @@
 (define-module (gnu system pam)
  #:use-module (guix records)
  #:use-module (guix derivations)
+  #:use-module (guix diagnostics)
  #:use-module (guix gexp)
+  #:use-module (guix i18n)
  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
  #:use-module (gnu system setuid)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
@ -55,6 +59,10 @@ (define-module (gnu system pam)
            session-environment-service
            session-environment-service-type

+            pam-extension
+            pam-extension-transformer
+            pam-extension-shepherd-requirements
+
            pam-root-service-type
            pam-root-service))

@ -347,32 +355,71 @@ (define (session-environment-service vars)
 ;;; PAM root service.
 ;;;

+;; Extension of the PAM configuration.  A PAM transformer consists of a
+;; procedure acting on each PAM entry; 'shepherd-requirements' lists services
+;; that the meta 'pam' Shepherd service will depend on.
+(define-record-type* <pam-extension>
+  pam-extension make-pam-extension pam-extension?
+  (transformer pam-extension-transformer)
+  (shepherd-requirements pam-extension-shepherd-requirements
+                         (default '())))
+
 ;; Overall PAM configuration: a list of services, plus a procedure that takes
 ;; one <pam-service> and returns a <pam-service>.  The procedure is used to
 ;; implement cross-cutting concerns such as the use of the 'elogind.so'
 ;; session module that keeps track of logged-in users.
 (define-record-type* <pam-configuration>
-  pam-configuration make-pam-configuration? pam-configuration?
-  (services  pam-configuration-services)          ;list of <pam-service>
-  (transform pam-configuration-transform))        ;procedure
+  pam-configuration make-pam-configuration pam-configuration?
+  ;list of <pam-service>
+  (services  pam-configuration-services)
+  ;list of procedures <pam-entry> -> <pam-entry>
+  (transformers pam-configuration-transformers)
+  ;list of symbols
+  (shepherd-requirements pam-configuration-shepherd-requirements))

 (define (/etc-entry config)
  "Return the /etc/pam.d entry corresponding to CONFIG."
  (match config
-    (($ <pam-configuration> services transform)
-     (let ((services (map transform services)))
+    (($ <pam-configuration> services transformers shepherd-requirements)
+     (let ((services (map (apply compose identity transformers)
+                          services)))
       `(("pam.d" ,(pam-services->directory services)))))))

+(define (pam-shepherd-service config)
+  "Return the PAM synchronization shepherd service corresponding to CONFIG."
+  (match config
+    (($ <pam-configuration> services transformers shepherd-requirements)
+     (list (shepherd-service
+            (documentation "Synchronization point for services that need to be
+started for PAM to work.")
+            (provision '(pam))
+            (requirement shepherd-requirements)
+            (start #~(const #t))
+            (stop #~(const #t)))))))
+
 (define (extend-configuration initial extensions)
  "Extend INITIAL with NEW."
-  (let-values (((services procs)
-                (partition pam-service? extensions)))
+  ;; TODO: Remove deprecation shim.
+  (define cleaned-extensions
+    (map (lambda (ext)
+           (if (procedure? ext)
+               (begin
+                 (warning (G_ "'pam-root-service-type' extensions should \
+now use the <pam-extension> record~%"))
+                 (pam-extension (transformer ext)))
+               ext))
+         extensions))
+
+  (let-values (((services pam-extensions)
+                (partition pam-service? cleaned-extensions)))
    (pam-configuration
     (services (append (pam-configuration-services initial)
                       services))
-     (transform (apply compose
-                       (pam-configuration-transform initial)
-                       procs)))))
+     (transformers (append (pam-configuration-transformers initial)
+                           (map pam-extension-transformer pam-extensions)))
+     (shepherd-requirements
+      (append (pam-configuration-shepherd-requirements initial)
+              (append-map pam-extension-shepherd-requirements pam-extensions))))))

 (define pam-root-service-type
  (service-type (name 'pam)
@ -382,7 +429,9 @@ (define pam-root-service-type
                        (lambda (_)
                          (list (file-like->setuid-program
                                 (file-append linux-pam "/sbin/unix_chkpwd")))))
-                       (service-extension etc-service-type /etc-entry)))
+                       (service-extension etc-service-type /etc-entry)
+                       (service-extension shepherd-root-service-type
+                                          pam-shepherd-service)))

                ;; Arguments include <pam-service> as well as procedures.
                (compose concatenate)
@ -394,7 +443,7 @@ (define pam-root-service-type
 program may authenticate users or what it should do when opening a new
 session.")))

-(define* (pam-root-service base #:key (transform identity))
+(define* (pam-root-service base #:key (transformers '()) (shepherd-requirements '()))
  "The \"root\" PAM service, which collects <pam-service> instance and turns
 them into a /etc/pam.d directory, including the <pam-service> listed in BASE.
 TRANSFORM is a procedure that takes a <pam-service> and returns a
@ -402,6 +451,7 @@ (define* (pam-root-service base #:key (transform identity))
 all the PAM services."
  (service pam-root-service-type
           (pam-configuration (services base)
-                              (transform transform))))
+                              (transformers transformers)
+                              (shepherd-requirements shepherd-requirements))))