gnu/build/activation.scm

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