services: Prevent following symlinks during activation.

This addresses a potential security issue, where a compromised
service could trick the activation code in changing the permissions,
owner and group of arbitrary files.  However, this patch is
currently only a partial fix, due to a TOCTTOU (time-of-check to
time-of-use) race, which can be fixed once guile has bindings
to openat and friends.

Fixes: <https://lists.gnu.org/archive/html/guix-devel/2021-01/msg00388.html>

* gnu/build/activation.scm: new procedure 'mkdir-p/perms'.
* gnu/services/authentication.scm
  (%nslcd-activation, nslcd-service-type): use new procedure.
* gnu/services/cups.scm (%cups-activation): likewise.
* gnu/services/dbus.scm (dbus-activation): likewise.
* gnu/services/dns.scm (knot-activation): likewise.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

1 files changed, 50 insertions, 3 deletions

diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index b458aee4ae..6cb6f8819b 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -1,6 +1,11 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
+;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,7 +42,8 @@
             activate-modprobe
             activate-firmware
             activate-ptrace-attach
-            activate-current-system))
+            activate-current-system
+            mkdir-p/perms))
 
 ;;; Commentary:
 ;;;
@@ -55,6 +61,47 @@
 (define (dot-or-dot-dot? file)
   (member file '("." "..")))
 
+;; Based upon mkdir-p from (guix build utils)
+(define (verify-not-symbolic dir)
+  "Verify DIR or its ancestors aren't symbolic links."
+  (define absolute?
+    (string-prefix? "/" dir))
+
+  (define not-slash
+    (char-set-complement (char-set #\/)))
+
+  (define (verify-component file)
+    (unless (eq? 'directory (stat:type (lstat file)))
+      (error "file name component is not a directory" dir)))
+
+  (let loop ((components (string-tokenize dir not-slash))
+             (root       (if absolute?
+                             ""
+                             ".")))
+    (match components
+      ((head tail ...)
+       (let ((file (string-append root "/" head)))
+         (catch 'system-error
+           (lambda ()
+             (verify-component file)
+             (loop tail file))
+           (lambda args
+             (if (= ENOENT (system-error-errno args))
+                 #t
+                 (apply throw args))))))
+      (() #t))))
+
+;; TODO: the TOCTTOU race can be addressed once guile has bindings
+;; for fstatat, openat and friends.
+(define (mkdir-p/perms directory owner bits)
+  "Create the directory DIRECTORY and all its ancestors.
+Verify no component of DIRECTORY is a symbolic link.
+Warning: this is currently suspect to a TOCTTOU race!"
+  (verify-not-symbolic directory)
+  (mkdir-p directory)
+  (chown directory (passwd:uid owner) (passwd:gid owner))
+  (chmod directory bits))
+
 (define* (copy-account-skeletons home
                                  #:key
                                  (directory %skeleton-directory)