gnu/build/activation.scm

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