gnu/build/activation.scm

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