services: Log-in services now require "pam_loginuid".

Fixes <https://bugs.gnu.org/35553>.
Reported by Bruno Haible <bruno@clisp.org>.

* gnu/services/base.scm (login-pam-service): Pass #:login-uid? #t to
'unix-pam-service'.
* gnu/services/ssh.scm (lsh-pam-services, openssh-pam-services):
Likewise.
* gnu/services/xorg.scm (slim-pam-service): Likewise.
(gdm-pam-service): Likewise for "gdm-autologin" and "gdm-password".
* gnu/tests/base.scm (run-basic-test)["getlogin on tty1"]: New test.
* gnu/tests/ssh.scm (run-ssh-test): Add #:test-getlogin? parameter.
["getlogin"]: New test.
(%test-dropbear): Pass #:test-getlogin? #f.

5 files changed, 44 insertions, 4 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 952f6f9ab2..015d873308 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -830,6 +830,7 @@ Return a service that sets up Unicode support in @var{tty} and loads
   "Return the list of PAM service needed for CONF."
   ;; Let 'login' be known to PAM.
   (list (unix-pam-service "login"
+                          #:login-uid? #t
                           #:allow-empty-passwords?
                           (login-configuration-allow-empty-passwords? config)
                           #:motd
diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm
index 25db783420..d026c3115e 100644
--- a/gnu/services/ssh.scm
+++ b/gnu/services/ssh.scm
@@ -182,6 +182,7 @@
   "Return a list of <pam-services> for lshd with CONFIG."
   (list (unix-pam-service
          "lshd"
+         #:login-uid? #t
          #:allow-empty-passwords?
          (lsh-configuration-allow-empty-passwords? config))))
 
@@ -506,6 +507,7 @@ of user-name/file-like tuples."
   "Return a list of <pam-services> for sshd with CONFIG."
   (list (unix-pam-service
          "sshd"
+         #:login-uid? #t
          #:allow-empty-passwords?
          (openssh-configuration-allow-empty-passwords? config))))
 
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index 29955754fa..3a9fa53d29 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -501,6 +501,7 @@ desktop session from the system or user profile will be used."
   "Return a PAM service for @command{slim}."
   (list (unix-pam-service
          "slim"
+         #:login-uid? #t
          #:allow-empty-passwords?
          (slim-configuration-allow-empty-passwords? config))))
 
@@ -830,7 +831,8 @@ the GNOME desktop environment.")
   "Return a PAM service for @command{gdm}."
   (list
    (pam-service
-    (inherit (unix-pam-service "gdm-autologin"))
+    (inherit (unix-pam-service "gdm-autologin"
+                               #:login-uid? #t))
     (auth (list (pam-entry
                  (control "[success=ok default=1]")
                  (module (file-append (gdm-configuration-gdm config)
@@ -844,6 +846,7 @@ the GNOME desktop environment.")
                  (control "required")
                  (module "pam_permit.so")))))
    (unix-pam-service "gdm-password"
+                     #:login-uid? #t
                      #:allow-empty-passwords?
                      (gdm-configuration-allow-empty-passwords? config))))
 
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index f9390ee8e4..d578f1977a 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -307,6 +307,18 @@ info --version")
               (wait-for-file "/root/logged-in" marionette
                              #:read 'get-string-all)))
 
+          (test-equal "getlogin on tty1"
+            "\"root\""
+            (begin
+              ;; Assume we logged in in the previous test and type.
+              (marionette-type "guile -c '(write (getlogin))' > /root/login-id\n"
+                               marionette)
+
+              ;; It can take a while before the shell commands are executed.
+              (marionette-eval '(use-modules (rnrs io ports)) marionette)
+              (wait-for-file "/root/login-id" marionette
+                             #:read 'get-string-all)))
+
           ;; There should be one utmpx entry for the user logged in on tty1.
           (test-equal "utmpx entry"
             '(("root" "tty1" #f))
diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm
index e5cd439cdf..a74227ea4a 100644
--- a/gnu/tests/ssh.scm
+++ b/gnu/tests/ssh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
 ;;;
@@ -31,7 +31,8 @@
   #:export (%test-openssh
             %test-dropbear))
 
-(define* (run-ssh-test name ssh-service pid-file #:key (sftp? #f))
+(define* (run-ssh-test name ssh-service pid-file
+                       #:key (sftp? #f) (test-getlogin? #t))
   "Run a test of an OS running SSH-SERVICE, which writes its PID to PID-FILE.
 SSH-SERVICE must be configured to listen on port 22 and to allow for root and
 empty-password logins.
@@ -54,10 +55,12 @@ When SFTP? is true, run an SFTP server test."
             (use-modules (gnu build marionette)
                          (srfi srfi-26)
                          (srfi srfi-64)
+                         (ice-9 textual-ports)
                          (ice-9 match)
                          (ssh session)
                          (ssh auth)
                          (ssh channel)
+                         (ssh popen)
                          (ssh sftp))
 
             (define marionette
@@ -147,6 +150,20 @@ root with an empty password."
                    (and (zero? (channel-get-exit-status channel))
                         (wait-for-file "/root/witness" marionette))))))
 
+            ;; Check whether the 'getlogin' procedure returns the right thing.
+            (unless #$test-getlogin?
+              (test-skip 1))
+            (test-equal "getlogin"
+              '(0 "root")
+              (call-with-connected-session/auth
+               (lambda (session)
+                 (let* ((pipe   (open-remote-input-pipe
+                                 session
+                                 "guile -c '(display (getlogin))'"))
+                        (output (get-string-all pipe))
+                        (status (channel-get-exit-status pipe)))
+                   (list status output)))))
+
             ;; Connect to the guest over SFTP.  Make sure we can write and
             ;; read a file there.
             (unless #$sftp?
@@ -217,4 +234,9 @@ root with an empty password."
                                  (dropbear-configuration
                                   (root-login? #t)
                                   (allow-empty-passwords? #t)))
-                        "/var/run/dropbear.pid"))))
+                        "/var/run/dropbear.pid"
+
+                        ;; XXX: Our Dropbear is not built with PAM support.
+                        ;; Even when it is, it seems to ignore the PAM
+                        ;; 'session' requirements.
+                        #:test-getlogin? #f))))