build-system/r: bioconductor-uri: Fix archive URL.
[jackhill/guix/guix.git] / gnu / build / activation.scm
index f24e602..4b67926 100644 (file)
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
   #:use-module (gnu build accounts)
   #:use-module (gnu build linux-boot)
   #:use-module (guix build utils)
+  #:use-module ((guix build syscalls) #:select (with-file-lock))
   #: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 +92,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,25 +114,42 @@ 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")
 
-  (let-values (((groups passwd shadow)
-                (user+group-databases users groups)))
-    (write-group groups)
-    (write-passwd passwd)
-    (write-shadow shadow)
-
-    ;; 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))))
+  ;; Take same lock as libc's 'lckpwdf' (but without a timeout) while we read
+  ;; and write the databases.  This ensures there's no race condition with
+  ;; other tools that might be accessing it at the same time.
+  (with-file-lock %password-lock-file
+    (let-values (((groups passwd shadow)
+                  (user+group-databases users groups)))
+      (write-group groups)
+      (write-passwd passwd)
+      (write-shadow shadow)))
+
+  ;; Home directories of non-system accounts are created by
+  ;; 'activate-user-home'.
+  (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
@@ -213,7 +247,19 @@ they already exist."
                          string<?))
       (mkdir-p %setuid-directory))
 
-  (for-each make-setuid-program programs))
+  (for-each (lambda (program)
+              (catch 'system-error
+                (lambda ()
+                  (make-setuid-program program))
+                (lambda args
+                  ;; If we fail to create a setuid program, better keep going
+                  ;; so that we don't leave %SETUID-DIRECTORY empty or
+                  ;; half-populated.  This can happen if PROGRAMS contains
+                  ;; incorrect file names: <https://bugs.gnu.org/38800>.
+                  (format (current-error-port)
+                          "warning: failed to make '~a' setuid-root: ~a~%"
+                          program (strerror (system-error-errno args))))))
+            programs))
 
 (define (activate-special-files special-files)
   "Install the files listed in SPECIAL-FILES.  Each element of SPECIAL-FILES
@@ -235,9 +281,13 @@ second element is the name it should appear at, such as:
 
 (define (activate-modprobe modprobe)
   "Tell the kernel to use MODPROBE to load modules."
-  (call-with-output-file "/proc/sys/kernel/modprobe"
-    (lambda (port)
-      (display modprobe port))))
+
+  ;; If the kernel was built without loadable module support, this file is
+  ;; unavailable, so check for its existence first.
+  (when (file-exists? "/proc/sys/kernel/modprobe")
+    (call-with-output-file "/proc/sys/kernel/modprobe"
+      (lambda (port)
+        (display modprobe port)))))
 
 (define (activate-firmware directory)
   "Tell the kernel to look for device firmware under DIRECTORY.  This
@@ -270,7 +320,9 @@ improvement."
 
 (define (boot-time-system)
   "Return the '--system' argument passed on the kernel command line."
-  (find-long-option "--system" (linux-command-line)))
+  (find-long-option "--system" (if (string-contains %host-type "linux-gnu")
+                                   (linux-command-line)
+                                   (command-line))))
 
 (define* (activate-current-system
           #:optional (system (or (getenv "GUIX_NEW_SYSTEM")