activation: Shared system home directories are now 555 and root-owned.

Fixes <https://bugs.gnu.org/34788>.
Reported by Jack Hill <jackhill@jackhill.us>.

Regression introduced by the combination of
8bb76f3d44c1f5ffec8011819494db306a51d801 and
0ae735bcc8ff7fdc89d67b492bdee9091ee19e86: /var/empty would be 700 and
owned by one of the system accounts (thus inaccessible to others), and
/var/run/dbus would be 700 as well, thereby preventing D-Bus clients
from connecting to the daemon.

* gnu/build/activation.scm (duplicates): New procedure.
(activate-users+groups)[system-accounts]: New variable.
Use it.  Make shared system account home directories #o555 and
root-owned.
* gnu/services/dbus.scm (dbus-activation): Make /var/run/dbus #o755.
* gnu/tests/base.scm (run-basic-test): Test the ownership and
permissions of /var/empty.

3 files changed, 46 insertions, 7 deletions

diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index f24e6029fa..cfdf17df0f 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -24,6 +24,7 @@
   #:use-module (guix build utils)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -90,6 +91,21 @@ owner-writable in HOME."
                     (make-file-writable target))))
               files)))
 
+(define (duplicates lst)
+  "Return elements from LST present more than once in LST."
+  (let loop ((lst lst)
+             (seen vlist-null)
+             (result '()))
+    (match lst
+      (()
+       (reverse result))
+      ((head . tail)
+       (loop tail
+             (vhash-cons head #t seen)
+             (if (vhash-assoc head seen)
+                 (cons head result)
+                 result))))))
+
 (define (activate-users+groups users groups)
   "Make sure USERS (a list of user account records) and GROUPS (a list of user
 group records) are all available."
@@ -97,9 +113,19 @@ group records) are all available."
     (let ((home (user-account-home-directory user))
           (pwd  (getpwnam (user-account-name user))))
       (mkdir-p home)
+
+      ;; Always set ownership and permissions for home directories of system
+      ;; accounts.  If a service needs looser permissions on its home
+      ;; directories, it can always chmod it in an activation snippet.
       (chown home (passwd:uid pwd) (passwd:gid pwd))
       (chmod home #o700)))
 
+  (define system-accounts
+    (filter (lambda (user)
+              (and (user-account-system? user)
+                   (user-account-create-home-directory? user)))
+            users))
+
   ;; Allow home directories to be created under /var/lib.
   (mkdir-p "/var/lib")
 
@@ -111,11 +137,14 @@ group records) are all available."
 
     ;; Home directories of non-system accounts are created by
     ;; 'activate-user-home'.
-    (for-each make-home-directory
-              (filter (lambda (user)
-                        (and (user-account-system? user)
-                             (user-account-create-home-directory? user)))
-                      users))))
+    (for-each make-home-directory system-accounts)
+
+    ;; Turn shared home directories, such as /var/empty, into root-owned,
+    ;; read-only places.
+    (for-each (lambda (directory)
+                (chown directory 0 0)
+                (chmod directory #o555))
+              (duplicates (map user-account-home-directory system-accounts)))))
 
 (define (activate-user-home users)
   "Create and populate the home directory of USERS, a list of tuples, unless
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index 1e24d93ccb..606ee0c2f5 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -150,7 +150,11 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in
 
       (let ((user (getpwnam "messagebus")))
         (chown "/var/run/dbus"
-               (passwd:uid user) (passwd:gid user)))
+               (passwd:uid user) (passwd:gid user))
+
+        ;; This directory contains the daemon's socket so it must be
+        ;; world-readable.
+        (chmod "/var/run/dbus" #o755))
 
       (unless (file-exists? "/etc/machine-id")
         (format #t "creating /etc/machine-id...~%")
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index cc8b273c98..f9390ee8e4 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -258,6 +258,12 @@ info --version")
                                     (operating-system-user-accounts os))))
               (stat:perms (marionette-eval `(stat ,root-home) marionette))))
 
+          (test-equal "ownership and permissions of /var/empty"
+            '(0 0 #o555)
+            (let ((st (marionette-eval `(stat "/var/empty") marionette)))
+              (list (stat:uid st) (stat:gid st)
+                    (stat:perms st))))
+
           (test-equal "no extra home directories"
             '()