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; likewise for GID."
 111   (define (set-owner file)
 112     (when (or uid gid)
 113       (chown file (or uid -1) (or gid -1))))
 114
 115   (let ((files (scandir directory (negate dot-or-dot-dot?)
 116                         string<?)))
 117     (mkdir-p home)
 118     (set-owner 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             (chown home uid gid)
 219             (chmod home #o700)
 220             (copy-account-skeletons home
 221                                     #:uid uid #:gid gid))))))
 222
 223   (for-each ensure-user-home users))
 224
 225 (define (activate-etc etc)
 226   "Install ETC, a directory in the store, as the source of static files for
 227 /etc."
 228
 229   ;; /etc is a mixture of static and dynamic settings.  Here is where we
 230   ;; initialize it from the static part.
 231
 232   (define (rm-f file)
 233     (false-if-exception (delete-file file)))
 234
 235   (format #t "populating /etc from ~a...~%" etc)
 236   (mkdir-p "/etc")
 237
 238   ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink.  This
 239   ;; symlink, to a target outside of the store, probably doesn't belong in the
 240   ;; static 'etc' store directory.  However, if it were to be put there,
 241   ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the
 242   ;; time of activation (e.g. when installing a fresh system), the call to
 243   ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'.
 244   (rm-f "/etc/ssl")
 245   (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl")
 246
 247   (rm-f "/etc/static")
 248   (symlink etc "/etc/static")
 249   (for-each (lambda (file)
 250               (let ((target (string-append "/etc/" file))
 251                     (source (string-append "/etc/static/" file)))
 252                 (rm-f target)
 253
 254                 ;; Things such as /etc/sudoers must be regular files, not
 255                 ;; symlinks; furthermore, they could be modified behind our
 256                 ;; back---e.g., with 'visudo'.  Thus, make a copy instead of
 257                 ;; symlinking them.
 258                 (if (file-is-directory? source)
 259                     (symlink source target)
 260                     (copy-file source target))
 261
 262                 ;; XXX: Dirty hack to meet sudo's expectations.
 263                 (when (string=? (basename target) "sudoers")
 264                   (chmod target #o440))))
 265             (scandir etc (negate dot-or-dot-dot?)
 266
 267                      ;; The default is 'string-locale<?', but we don't have
 268                      ;; it when run from the initrd's statically-linked
 269                      ;; Guile.
 270                      string<?)))
 271
 272 (define %setuid-directory
 273   ;; Place where setuid programs are stored.
 274   "/run/setuid-programs")
 275
 276 (define (activate-setuid-programs programs)
 277   "Turn PROGRAMS, a list of file names, into setuid programs stored under
 278 %SETUID-DIRECTORY."
 279   (define (make-setuid-program prog)
 280     (let ((target (string-append %setuid-directory
 281                                  "/" (basename prog))))
 282       (copy-file prog target)
 283       (chown target 0 0)
 284       (chmod target #o4555)))
 285
 286   (format #t "setting up setuid programs in '~a'...~%"
 287           %setuid-directory)
 288   (if (file-exists? %setuid-directory)
 289       (for-each (compose delete-file
 290                          (cut string-append %setuid-directory "/" <>))
 291                 (scandir %setuid-directory
 292                          (lambda (file)
 293                            (not (member file '("." ".."))))
 294                          string<?))
 295       (mkdir-p %setuid-directory))
 296
 297   (for-each (lambda (program)
 298               (catch 'system-error
 299                 (lambda ()
 300                   (make-setuid-program program))
 301                 (lambda args
 302                   ;; If we fail to create a setuid program, better keep going
 303                   ;; so that we don't leave %SETUID-DIRECTORY empty or
 304                   ;; half-populated.  This can happen if PROGRAMS contains
 305                   ;; incorrect file names: <https://bugs.gnu.org/38800>.
 306                   (format (current-error-port)
 307                           "warning: failed to make '~a' setuid-root: ~a~%"
 308                           program (strerror (system-error-errno args))))))
 309             programs))
 310
 311 (define (activate-special-files special-files)
 312   "Install the files listed in SPECIAL-FILES.  Each element of SPECIAL-FILES
 313 is a pair where the first element is the name of the special file and the
 314 second element is the name it should appear at, such as:
 315
 316   ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\")
 317    (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\"))
 318 "
 319   (define install-special-file
 320     (match-lambda
 321       ((target file)
 322        (let ((pivot (string-append target ".new")))
 323          (mkdir-p (dirname target))
 324          (symlink file pivot)
 325          (rename-file pivot target)))))
 326
 327   (for-each install-special-file special-files))
 328
 329 (define (activate-modprobe modprobe)
 330   "Tell the kernel to use MODPROBE to load modules."
 331
 332   ;; If the kernel was built without loadable module support, this file is
 333   ;; unavailable, so check for its existence first.
 334   (when (file-exists? "/proc/sys/kernel/modprobe")
 335     (call-with-output-file "/proc/sys/kernel/modprobe"
 336       (lambda (port)
 337         (display modprobe port)))))
 338
 339 (define (activate-firmware directory)
 340   "Tell the kernel to look for device firmware under DIRECTORY.  This
 341 mechanism bypasses udev: it allows Linux to handle firmware loading directly
 342 by itself, without having to resort to a \"user helper\"."
 343   (call-with-output-file "/sys/module/firmware_class/parameters/path"
 344     (lambda (port)
 345       (display directory port))))
 346
 347 (define (activate-ptrace-attach)
 348   "Allow users to PTRACE_ATTACH their own processes.
 349
 350 This works around a regression introduced in the default \"security\" policy
 351 found in Linux 3.4 onward that prevents users from attaching to their own
 352 processes--see Yama.txt in the Linux source tree for the rationale.  This
 353 sounds like an unacceptable restriction for little or no security
 354 improvement."
 355   (let ((file "/proc/sys/kernel/yama/ptrace_scope"))
 356     (when (file-exists? file)
 357       (call-with-output-file file
 358         (lambda (port)
 359           (display 0 port))))))
 360
 361 \f
 362 (define %current-system
 363   ;; The system that is current (a symlink.)  This is not necessarily the same
 364   ;; as the system we booted (aka. /run/booted-system) because we can re-build
 365   ;; a new system configuration and activate it, without rebooting.
 366   "/run/current-system")
 367
 368 (define (boot-time-system)
 369   "Return the '--system' argument passed on the kernel command line."
 370   (find-long-option "--system" (if (string-contains %host-type "linux-gnu")
 371                                    (linux-command-line)
 372                                    (command-line))))
 373
 374 (define* (activate-current-system
 375           #:optional (system (or (getenv "GUIX_NEW_SYSTEM")
 376                                  (boot-time-system))))
 377   "Atomically make SYSTEM the current system."
 378   ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix
 379   ;; system reconfigure' to pass the file name of the new system.
 380
 381   (format #t "making '~a' the current system...~%" system)
 382
 383   ;; Atomically make SYSTEM current.
 384   (let ((new (string-append %current-system ".new")))
 385     (symlink system new)
 386     (rename-file new %current-system)))
 387
 388 ;;; activation.scm ends here