gnu/build/activation.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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 build linux-boot)
  22   #:use-module (guix build utils)
  23   #:use-module (ice-9 ftw)
  24   #:use-module (ice-9 match)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-26)
  27   #:export (activate-users+groups
  28             activate-user-home
  29             activate-etc
  30             activate-setuid-programs
  31             activate-special-files
  32             activate-modprobe
  33             activate-firmware
  34             activate-ptrace-attach
  35             activate-current-system))
  36
  37 ;;; Commentary:
  38 ;;;
  39 ;;; This module provides "activation" helpers.  Activation is the process that
  40 ;;; consists in setting up system-wide files and directories so that an
  41 ;;; 'operating-system' configuration becomes active.
  42 ;;;
  43 ;;; Code:
  44
  45 (define (enumerate thunk)
  46   "Return the list of values returned by THUNK until it returned #f."
  47   (let loop ((entry  (thunk))
  48              (result '()))
  49     (if (not entry)
  50         (reverse result)
  51         (loop (thunk) (cons entry result)))))
  52
  53 (define (current-users)
  54   "Return the passwd entries for all the currently defined user accounts."
  55   (setpw)
  56   (enumerate getpwent))
  57
  58 (define (current-groups)
  59   "Return the group entries for all the currently defined user groups."
  60   (setgr)
  61   (enumerate getgrent))
  62
  63 (define* (add-group name #:key gid password system?
  64                     (log-port (current-error-port)))
  65   "Add NAME as a user group, with the given numeric GID if specified."
  66   ;; Use 'groupadd' from the Shadow package.
  67   (format log-port "adding group '~a'...~%" name)
  68   (let ((args `(,@(if gid `("-g" ,(number->string gid)) '())
  69                 ,@(if password `("-p" ,password) '())
  70                 ,@(if system? `("--system") '())
  71                 ,name)))
  72     (zero? (apply system* "groupadd" args))))
  73
  74 (define %skeleton-directory
  75   ;; Directory containing skeleton files for new accounts.
  76   ;; Note: keep the trailing '/' so that 'scandir' enters it.
  77   "/etc/skel/")
  78
  79 (define (dot-or-dot-dot? file)
  80   (member file '("." "..")))
  81
  82 (define* (copy-account-skeletons home
  83                                  #:key
  84                                  (directory %skeleton-directory)
  85                                  uid gid)
  86   "Copy the account skeletons from DIRECTORY to HOME.  When UID is an integer,
  87 make it the owner of all the files created; likewise for GID."
  88   (define (set-owner file)
  89     (when (or uid gid)
  90       (chown file (or uid -1) (or gid -1))))
  91
  92   (let ((files (scandir directory (negate dot-or-dot-dot?)
  93                         string<?)))
  94     (mkdir-p home)
  95     (set-owner home)
  96     (for-each (lambda (file)
  97                 (let ((target (string-append home "/" file)))
  98                   (copy-recursively (string-append directory "/" file)
  99                                     target
 100                                     #:log (%make-void-port "w"))
 101                   (for-each set-owner
 102                             (find-files target (const #t)
 103                                         #:directories? #t))
 104                   (make-file-writable target)))
 105               files)))
 106
 107 (define* (make-skeletons-writable home
 108                                   #:optional (directory %skeleton-directory))
 109   "Make sure that the files that have been copied from DIRECTORY to HOME are
 110 owner-writable in HOME."
 111   (let ((files (scandir directory (negate dot-or-dot-dot?)
 112                         string<?)))
 113     (for-each (lambda (file)
 114                 (let ((target (string-append home "/" file)))
 115                   (when (file-exists? target)
 116                     (make-file-writable target))))
 117               files)))
 118
 119 (define* (add-user name group
 120                    #:key uid comment home create-home?
 121                    shell password system?
 122                    (supplementary-groups '())
 123                    (log-port (current-error-port)))
 124   "Create an account for user NAME part of GROUP, with the specified
 125 properties.  Return #t on success."
 126   (format log-port "adding user '~a'...~%" name)
 127
 128   (if (and uid (zero? uid))
 129
 130       ;; 'useradd' fails with "Cannot determine your user name" if the root
 131       ;; account doesn't exist.  Thus, for bootstrapping purposes, create that
 132       ;; one manually.
 133       (let ((home (or home "/root")))
 134         (call-with-output-file "/etc/shadow"
 135           (cut format <> "~a::::::::~%" name))
 136         (call-with-output-file "/etc/passwd"
 137           (cut format <> "~a:x:~a:~a:~a:~a:~a~%"
 138                name "0" "0" comment home shell))
 139         (chmod "/etc/shadow" #o600)
 140         (copy-account-skeletons home)
 141         (chmod home #o700)
 142         #t)
 143
 144       ;; Use 'useradd' from the Shadow package.
 145       (let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
 146                     "-g" ,(if (number? group) (number->string group) group)
 147                     ,@(if (pair? supplementary-groups)
 148                           `("-G" ,(string-join supplementary-groups ","))
 149                           '())
 150                     ,@(if comment `("-c" ,comment) '())
 151                     ,@(if home `("-d" ,home) '())
 152
 153                     ;; Home directories of non-system accounts are created by
 154                     ;; 'activate-user-home'.
 155                     ,@(if (and home create-home? system?
 156                                (not (file-exists? home)))
 157                           '("--create-home")
 158                           '())
 159
 160                     ,@(if shell `("-s" ,shell) '())
 161                     ,@(if password `("-p" ,password) '())
 162                     ,@(if system? '("--system") '())
 163                     ,name)))
 164         (and (zero? (apply system* "useradd" args))
 165              (begin
 166                ;; Since /etc/skel is a link to a directory in the store where
 167                ;; all files have the writable bit cleared, and since 'useradd'
 168                ;; preserves permissions when it copies them, explicitly make
 169                ;; them writable.
 170                (make-skeletons-writable home)
 171                #t)))))
 172
 173 (define* (modify-user name group
 174                       #:key uid comment home create-home?
 175                       shell password system?
 176                       (supplementary-groups '())
 177                       (log-port (current-error-port)))
 178   "Modify user account NAME to have all the given settings."
 179   ;; Use 'usermod' from the Shadow package.
 180   (let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
 181                 "-g" ,(if (number? group) (number->string group) group)
 182                 ,@(if (pair? supplementary-groups)
 183                       `("-G" ,(string-join supplementary-groups ","))
 184                       '())
 185                 ,@(if comment `("-c" ,comment) '())
 186                 ;; Don't use '--move-home'.
 187                 ,@(if home `("-d" ,home) '())
 188                 ,@(if shell `("-s" ,shell) '())
 189                 ,name)))
 190     (zero? (apply system* "usermod" args))))
 191
 192 (define* (delete-user name #:key (log-port (current-error-port)))
 193   "Remove user account NAME.  Return #t on success.  This may fail if NAME is
 194 logged in."
 195   (format log-port "deleting user '~a'...~%" name)
 196   (zero? (system* "userdel" name)))
 197
 198 (define* (delete-group name #:key (log-port (current-error-port)))
 199   "Remove group NAME.  Return #t on success."
 200   (format log-port "deleting group '~a'...~%" name)
 201   (zero? (system* "groupdel" name)))
 202
 203 (define* (ensure-user name group
 204                       #:key uid comment home create-home?
 205                       shell password system?
 206                       (supplementary-groups '())
 207                       (log-port (current-error-port))
 208                       #:rest rest)
 209   "Make sure user NAME exists and has the relevant settings."
 210   (if (false-if-exception (getpwnam name))
 211       (apply modify-user name group rest)
 212       (apply add-user name group rest)))
 213
 214 (define (activate-users+groups users groups)
 215   "Make sure the accounts listed in USERS and the user groups listed in GROUPS
 216 are all available.
 217
 218 Each item in USERS is a list of all the characteristics of a user account;
 219 each item in GROUPS is a tuple with the group name, group password or #f, and
 220 numeric gid or #f."
 221   (define (touch file)
 222     (close-port (open-file file "a0b")))
 223
 224   (define activate-user
 225     (match-lambda
 226      ((name uid group supplementary-groups comment home create-home?
 227        shell password system?)
 228       (let ((profile-dir (string-append "/var/guix/profiles/per-user/"
 229                                         name)))
 230         (ensure-user name group
 231                      #:uid uid
 232                      #:system? system?
 233                      #:supplementary-groups supplementary-groups
 234                      #:comment comment
 235                      #:home home
 236                      #:create-home? create-home?
 237
 238                      #:shell shell
 239                      #:password password)
 240
 241         (unless system?
 242           ;; Create the profile directory for the new account.
 243           (let ((pw (getpwnam name)))
 244             (mkdir-p profile-dir)
 245             (chown profile-dir (passwd:uid pw) (passwd:gid pw))))))))
 246
 247   ;; 'groupadd' aborts if the file doesn't already exist.
 248   (touch "/etc/group")
 249
 250   ;; Allow home directories to be created under /var/lib.
 251   (mkdir-p "/var/lib")
 252
 253   ;; Create the root account so we can use 'useradd' and 'groupadd'.
 254   (activate-user (find (match-lambda
 255                         ((name (? zero?) _ ...) #t)
 256                         (_ #f))
 257                        users))
 258
 259   ;; Then create the groups.
 260   (for-each (match-lambda
 261              ((name password gid system?)
 262               (unless (false-if-exception (getgrnam name))
 263                 (add-group name
 264                            #:gid gid #:password password
 265                            #:system? system?))))
 266             groups)
 267
 268   ;; Create the other user accounts.
 269   (for-each activate-user users)
 270
 271   ;; Finally, delete extra user accounts and groups.
 272   (for-each delete-user
 273             (lset-difference string=?
 274                              (map passwd:name (current-users))
 275                              (match users
 276                                (((names . _) ...)
 277                                 names))))
 278   (for-each delete-group
 279             (lset-difference string=?
 280                              (map group:name (current-groups))
 281                              (match groups
 282                                (((names . _) ...)
 283                                 names)))))
 284
 285 (define (activate-user-home users)
 286   "Create and populate the home directory of USERS, a list of tuples, unless
 287 they already exist."
 288   (define ensure-user-home
 289     (match-lambda
 290       ((name uid group supplementary-groups comment home create-home?
 291              shell password system?)
 292        ;; The home directories of system accounts are created during
 293        ;; activation, not here.
 294        (unless (or (not home) (not create-home?) system?
 295                    (directory-exists? home))
 296          (let* ((pw  (getpwnam name))
 297                 (uid (passwd:uid pw))
 298                 (gid (passwd:gid pw)))
 299            (mkdir-p home)
 300            (chown home uid gid)
 301            (unless system?
 302              (copy-account-skeletons home
 303                                      #:uid uid #:gid gid)))))))
 304
 305   (for-each ensure-user-home users))
 306
 307 (define (activate-etc etc)
 308   "Install ETC, a directory in the store, as the source of static files for
 309 /etc."
 310
 311   ;; /etc is a mixture of static and dynamic settings.  Here is where we
 312   ;; initialize it from the static part.
 313
 314   (define (rm-f file)
 315     (false-if-exception (delete-file file)))
 316
 317   (format #t "populating /etc from ~a...~%" etc)
 318   (mkdir-p "/etc")
 319
 320   ;; Create the /etc/ssl -> /run/current-system/profile/etc/ssl symlink.  This
 321   ;; symlink, to a target outside of the store, probably doesn't belong in the
 322   ;; static 'etc' store directory.  However, if it were to be put there,
 323   ;; beware that if /run/current-system/profile/etc/ssl doesn't exist at the
 324   ;; time of activation (e.g. when installing a fresh system), the call to
 325   ;; 'file-is-directory?' below will fail because it uses 'stat', not 'lstat'.
 326   (rm-f "/etc/ssl")
 327   (symlink "/run/current-system/profile/etc/ssl" "/etc/ssl")
 328
 329   (rm-f "/etc/static")
 330   (symlink etc "/etc/static")
 331   (for-each (lambda (file)
 332               (let ((target (string-append "/etc/" file))
 333                     (source (string-append "/etc/static/" file)))
 334                 (rm-f target)
 335
 336                 ;; Things such as /etc/sudoers must be regular files, not
 337                 ;; symlinks; furthermore, they could be modified behind our
 338                 ;; back---e.g., with 'visudo'.  Thus, make a copy instead of
 339                 ;; symlinking them.
 340                 (if (file-is-directory? source)
 341                     (symlink source target)
 342                     (copy-file source target))
 343
 344                 ;; XXX: Dirty hack to meet sudo's expectations.
 345                 (when (string=? (basename target) "sudoers")
 346                   (chmod target #o440))))
 347             (scandir etc (negate dot-or-dot-dot?)
 348
 349                      ;; The default is 'string-locale<?', but we don't have
 350                      ;; it when run from the initrd's statically-linked
 351                      ;; Guile.
 352                      string<?)))
 353
 354 (define %setuid-directory
 355   ;; Place where setuid programs are stored.
 356   "/run/setuid-programs")
 357
 358 (define (activate-setuid-programs programs)
 359   "Turn PROGRAMS, a list of file names, into setuid programs stored under
 360 %SETUID-DIRECTORY."
 361   (define (make-setuid-program prog)
 362     (let ((target (string-append %setuid-directory
 363                                  "/" (basename prog))))
 364       (copy-file prog target)
 365       (chown target 0 0)
 366       (chmod target #o6555)))
 367
 368   (format #t "setting up setuid programs in '~a'...~%"
 369           %setuid-directory)
 370   (if (file-exists? %setuid-directory)
 371       (for-each (compose delete-file
 372                          (cut string-append %setuid-directory "/" <>))
 373                 (scandir %setuid-directory
 374                          (lambda (file)
 375                            (not (member file '("." ".."))))
 376                          string<?))
 377       (mkdir-p %setuid-directory))
 378
 379   (for-each make-setuid-program programs))
 380
 381 (define (activate-special-files special-files)
 382   "Install the files listed in SPECIAL-FILES.  Each element of SPECIAL-FILES
 383 is a pair where the first element is the name of the special file and the
 384 second element is the name it should appear at, such as:
 385
 386   ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\")
 387    (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\"))
 388 "
 389   (define install-special-file
 390     (match-lambda
 391       ((target file)
 392        (let ((pivot (string-append target ".new")))
 393          (mkdir-p (dirname target))
 394          (symlink file pivot)
 395          (rename-file pivot target)))))
 396
 397   (for-each install-special-file special-files))
 398
 399 (define (activate-modprobe modprobe)
 400   "Tell the kernel to use MODPROBE to load modules."
 401   (call-with-output-file "/proc/sys/kernel/modprobe"
 402     (lambda (port)
 403       (display modprobe port))))
 404
 405 (define (activate-firmware directory)
 406   "Tell the kernel to look for device firmware under DIRECTORY.  This
 407 mechanism bypasses udev: it allows Linux to handle firmware loading directly
 408 by itself, without having to resort to a \"user helper\"."
 409   (call-with-output-file "/sys/module/firmware_class/parameters/path"
 410     (lambda (port)
 411       (display directory port))))
 412
 413 (define (activate-ptrace-attach)
 414   "Allow users to PTRACE_ATTACH their own processes.
 415
 416 This works around a regression introduced in the default \"security\" policy
 417 found in Linux 3.4 onward that prevents users from attaching to their own
 418 processes--see Yama.txt in the Linux source tree for the rationale.  This
 419 sounds like an unacceptable restriction for little or no security
 420 improvement."
 421   (let ((file "/proc/sys/kernel/yama/ptrace_scope"))
 422     (when (file-exists? file)
 423       (call-with-output-file file
 424         (lambda (port)
 425           (display 0 port))))))
 426
 427 \f
 428 (define %current-system
 429   ;; The system that is current (a symlink.)  This is not necessarily the same
 430   ;; as the system we booted (aka. /run/booted-system) because we can re-build
 431   ;; a new system configuration and activate it, without rebooting.
 432   "/run/current-system")
 433
 434 (define (boot-time-system)
 435   "Return the '--system' argument passed on the kernel command line."
 436   (find-long-option "--system" (linux-command-line)))
 437
 438 (define* (activate-current-system
 439           #:optional (system (or (getenv "GUIX_NEW_SYSTEM")
 440                                  (boot-time-system))))
 441   "Atomically make SYSTEM the current system."
 442   ;; The 'GUIX_NEW_SYSTEM' environment variable is used as a way for 'guix
 443   ;; system reconfigure' to pass the file name of the new system.
 444
 445   (format #t "making '~a' the current system...~%" system)
 446
 447   ;; Atomically make SYSTEM current.
 448   (let ((new (string-append %current-system ".new")))
 449     (symlink system new)
 450     (rename-file new %current-system)))
 451
 452 ;;; activation.scm ends here