gnu/build/activation.scm

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