gnu/build/activation.scm

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