gnu/build/activation.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu build activation)
  21   #:use-module (gnu system accounts)
  22   #:use-module (gnu build accounts)
  23   #:use-module (gnu build linux-boot)
  24   #:use-module (guix build utils)
  25   #:use-module ((guix build syscalls) #:select (with-file-lock))
  26   #:use-module (ice-9 ftw)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 vlist)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-11)
  31   #:use-module (srfi srfi-26)
  32   #:export (activate-users+groups
  33             activate-user-home
  34             activate-etc
  35             activate-setuid-programs
  36             activate-special-files
  37             activate-modprobe
  38             activate-firmware
  39             activate-ptrace-attach
  40             activate-current-system))
  41
  42 ;;; Commentary:
  43 ;;;
  44 ;;; This module provides "activation" helpers.  Activation is the process that
  45 ;;; consists in setting up system-wide files and directories so that an
  46 ;;; 'operating-system' configuration becomes active.
  47 ;;;
  48 ;;; Code:
  49
  50 (define %skeleton-directory
  51   ;; Directory containing skeleton files for new accounts.
  52   ;; Note: keep the trailing '/' so that 'scandir' enters it.
  53   "/etc/skel/")
  54
  55 (define (dot-or-dot-dot? file)
  56   (member file '("." "..")))
  57
  58 (define* (copy-account-skeletons home
  59                                  #:key
  60                                  (directory %skeleton-directory)
  61                                  uid gid)
  62   "Copy the account skeletons from DIRECTORY to HOME.  When UID is an integer,
  63 make it the owner of all the files created; likewise for GID."
  64   (define (set-owner file)
  65     (when (or uid gid)
  66       (chown file (or uid -1) (or gid -1))))
  67
  68   (let ((files (scandir directory (negate dot-or-dot-dot?)
  69                         string<?)))
  70     (mkdir-p home)
  71     (set-owner home)
  72     (for-each (lambda (file)
  73                 (let ((target (string-append home "/" file)))
  74                   (copy-recursively (string-append directory "/" file)
  75                                     target
  76                                     #:log (%make-void-port "w"))
  77                   (for-each set-owner
  78                             (find-files target (const #t)
  79                                         #:directories? #t))
  80                   (make-file-writable target)))
  81               files)))
  82
  83 (define* (make-skeletons-writable home
  84                                   #:optional (directory %skeleton-directory))
  85   "Make sure that the files that have been copied from DIRECTORY to HOME are
  86 owner-writable in HOME."
  87   (let ((files (scandir directory (negate dot-or-dot-dot?)
  88                         string<?)))
  89     (for-each (lambda (file)
  90                 (let ((target (string-append home "/" file)))
  91                   (when (file-exists? target)
  92                     (make-file-writable target))))
  93               files)))
  94
  95 (define (duplicates lst)
  96   "Return elements from LST present more than once in LST."
  97   (let loop ((lst lst)
  98              (seen vlist-null)
  99              (result '()))
 100     (match lst
 101       (()
 102        (reverse result))
 103       ((head . tail)
 104        (loop tail
 105              (vhash-cons head #t seen)
 106              (if (vhash-assoc head seen)
 107                  (cons head result)
 108                  result))))))
 109
 110 (define (activate-users+groups users groups)
 111   "Make sure USERS (a list of user account records) and GROUPS (a list of user
 112 group records) are all available."
 113   (define (make-home-directory user)
 114     (let ((home (user-account-home-directory user))
 115           (pwd  (getpwnam (user-account-name user))))
 116       (mkdir-p home)
 117
 118       ;; Always set ownership and permissions for home directories of system
 119       ;; accounts.  If a service needs looser permissions on its home
 120       ;; directories, it can always chmod it in an activation snippet.
 121       (chown home (passwd:uid pwd) (passwd:gid pwd))
 122       (chmod home #o700)))
 123
 124   (define system-accounts
 125     (filter (lambda (user)
 126               (and (user-account-system? user)
 127                    (user-account-create-home-directory? user)))
 128             users))
 129
 130   ;; Allow home directories to be created under /var/lib.
 131   (mkdir-p "/var/lib")
 132
 133   ;; Take same lock as libc's 'lckpwdf' (but without a timeout) while we read
 134   ;; and write the databases.  This ensures there's no race condition with
 135   ;; other tools that might be accessing it at the same time.
 136   (with-file-lock %password-lock-file
 137     (let-values (((groups passwd shadow)
 138                   (user+group-databases users groups)))
 139       (write-group groups)
 140       (write-passwd passwd)
 141       (write-shadow shadow)))
 142
 143   ;; Home directories of non-system accounts are created by
 144   ;; 'activate-user-home'.
 145   (for-each make-home-directory system-accounts)
 146
 147   ;; Turn shared home directories, such as /var/empty, into root-owned,
 148   ;; read-only places.
 149   (for-each (lambda (directory)
 150               (chown directory 0 0)
 151               (chmod directory #o555))
 152             (duplicates (map user-account-home-directory system-accounts))))
 153
 154 (define (activate-user-home users)
 155   "Create and populate the home directory of USERS, a list of tuples, unless
 156 they already exist."
 157   (define ensure-user-home
 158     (lambda (user)
 159       (let ((name         (user-account-name user))
 160             (home         (user-account-home-directory user))
 161             (create-home? (user-account-create-home-directory? user))
 162             (system?      (user-account-system? user)))
 163         ;; The home directories of system accounts are created during
 164         ;; activation, not here.
 165         (unless (or (not home) (not create-home?) system?
 166                     (directory-exists? home))
 167           (let* ((pw  (getpwnam name))
 168                  (uid (passwd:uid pw))
 169                  (gid (passwd:gid pw)))
 170             (mkdir-p home)
 171             (chown home uid gid)
 172             (chmod home #o700)
 173             (copy-account-skeletons home
 174                                     #:uid uid #:gid gid))))))
 175
 176   (for-each ensure-user-home users))
 177
 178 (define (activate-etc etc)
 179   "Install ETC, a directory in the store, as the source of static files for
 180 /etc."
 181
 182   ;; /etc is a mixture of static and dynamic settings.  Here is where we
 183   ;; initialize it from the static part.
 184
 185   (define (rm-f file)
 186     (false-if-exception (delete-file file)))
 187
 188   (format #t "populating /etc from ~a...~%" etc)
 189   (mkdir-p "/etc")
 190
 191   ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink.  This
 192   ;; symlink, to a target outside of the store, probably doesn't belong in the
 193   ;; static 'etc' store directory.  However, if it were to be put there,
 194   ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the
 195   ;; time of activation (e.g. when installing a fresh system), the call to
 196   ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'.
 197   (rm-f "/etc/ssl")
 198   (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl")
 199
 200   (rm-f "/etc/static")
 201   (symlink etc "/etc/static")
 202   (for-each (lambda (file)
 203               (let ((target (string-append "/etc/" file))
 204                     (source (string-append "/etc/static/" file)))
 205                 (rm-f target)
 206
 207                 ;; Things such as /etc/sudoers must be regular files, not
 208                 ;; symlinks; furthermore, they could be modified behind our
 209                 ;; back---e.g., with 'visudo'.  Thus, make a copy instead of
 210                 ;; symlinking them.
 211                 (if (file-is-directory? source)
 212                     (symlink source target)
 213                     (copy-file source target))
 214
 215                 ;; XXX: Dirty hack to meet sudo's expectations.
 216                 (when (string=? (basename target) "sudoers")
 217                   (chmod target #o440))))
 218             (scandir etc (negate dot-or-dot-dot?)
 219
 220                      ;; The default is 'string-locale<?', but we don't have
 221                      ;; it when run from the initrd's statically-linked
 222                      ;; Guile.
 223                      string<?)))
 224
 225 (define %setuid-directory
 226   ;; Place where setuid programs are stored.
 227   "/run/setuid-programs")
 228
 229 (define (activate-setuid-programs programs)
 230   "Turn PROGRAMS, a list of file names, into setuid programs stored under
 231 %SETUID-DIRECTORY."
 232   (define (make-setuid-program prog)
 233     (let ((target (string-append %setuid-directory
 234                                  "/" (basename prog))))
 235       (copy-file prog target)
 236       (chown target 0 0)
 237       (chmod target #o4555)))
 238
 239   (format #t "setting up setuid programs in '~a'...~%"
 240           %setuid-directory)
 241   (if (file-exists? %setuid-directory)
 242       (for-each (compose delete-file
 243                          (cut string-append %setuid-directory "/" <>))
 244                 (scandir %setuid-directory
 245                          (lambda (file)
 246                            (not (member file '("." ".."))))
 247                          string<?))
 248       (mkdir-p %setuid-directory))
 249
 250   (for-each (lambda (program)
 251               (catch 'system-error
 252                 (lambda ()
 253                   (make-setuid-program program))
 254                 (lambda args
 255                   ;; If we fail to create a setuid program, better keep going
 256                   ;; so that we don't leave %SETUID-DIRECTORY empty or
 257                   ;; half-populated.  This can happen if PROGRAMS contains
 258                   ;; incorrect file names: <https://bugs.gnu.org/38800>.
 259                   (format (current-error-port)
 260                           "warning: failed to make '~a' setuid-root: ~a~%"
 261                           program (strerror (system-error-errno args))))))
 262             programs))
 263
 264 (define (activate-special-files special-files)
 265   "Install the files listed in SPECIAL-FILES.  Each element of SPECIAL-FILES
 266 is a pair where the first element is the name of the special file and the
 267 second element is the name it should appear at, such as:
 268
 269   ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\")
 270    (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\"))
 271 "
 272   (define install-special-file
 273     (match-lambda
 274       ((target file)
 275        (let ((pivot (string-append target ".new")))
 276          (mkdir-p (dirname target))
 277          (symlink file pivot)
 278          (rename-file pivot target)))))
 279
 280   (for-each install-special-file special-files))
 281
 282 (define (activate-modprobe modprobe)
 283   "Tell the kernel to use MODPROBE to load modules."
 284
 285   ;; If the kernel was built without loadable module support, this file is
 286   ;; unavailable, so check for its existence first.
 287   (when (file-exists? "/proc/sys/kernel/modprobe")
 288     (call-with-output-file "/proc/sys/kernel/modprobe"
 289       (lambda (port)
 290         (display modprobe port)))))
 291
 292 (define (activate-firmware directory)
 293   "Tell the kernel to look for device firmware under DIRECTORY.  This
 294 mechanism bypasses udev: it allows Linux to handle firmware loading directly
 295 by itself, without having to resort to a \"user helper\"."
 296   (call-with-output-file "/sys/module/firmware_class/parameters/path"
 297     (lambda (port)
 298       (display directory port))))
 299
 300 (define (activate-ptrace-attach)
 301   "Allow users to PTRACE_ATTACH their own processes.
 302
 303 This works around a regression introduced in the default \"security\" policy
 304 found in Linux 3.4 onward that prevents users from attaching to their own
 305 processes--see Yama.txt in the Linux source tree for the rationale.  This
 306 sounds like an unacceptable restriction for little or no security
 307 improvement."
 308   (let ((file "/proc/sys/kernel/yama/ptrace_scope"))
 309     (when (file-exists? file)
 310       (call-with-output-file file
 311         (lambda (port)
 312           (display 0 port))))))
 313
 314 \f
 315 (define %current-system
 316   ;; The system that is current (a symlink.)  This is not necessarily the same
 317   ;; as the system we booted (aka. /run/booted-system) because we can re-build
 318   ;; a new system configuration and activate it, without rebooting.
 319   "/run/current-system")
 320
 321 (define (boot-time-system)
 322   "Return the '--system' argument passed on the kernel command line."
 323   (find-long-option "--system" (if (string-contains %host-type "linux-gnu")
 324                                    (linux-command-line)
 325                                    (command-line))))
 326
 327 (define* (activate-current-system
 328           #:optional (system (or (getenv "GUIX_NEW_SYSTEM")
 329                                  (boot-time-system))))
 330   "Atomically make SYSTEM the current system."
 331   ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix
 332   ;; system reconfigure' to pass the file name of the new system.
 333
 334   (format #t "making '~a' the current system...~%" system)
 335
 336   ;; Atomically make SYSTEM current.
 337   (let ((new (string-append %current-system ".new")))
 338     (symlink system new)
 339     (rename-file new %current-system)))
 340
 341 ;;; activation.scm ends here