gnu/system/install.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015 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 system install)
  20   #:use-module (gnu)
  21   #:use-module (guix gexp)
  22   #:use-module (guix store)
  23   #:use-module (guix monads)
  24   #:use-module ((guix store) #:select (%store-prefix))
  25   #:use-module (guix profiles)
  26   #:use-module (gnu packages admin)
  27   #:use-module (gnu packages bash)
  28   #:use-module (gnu packages linux)
  29   #:use-module (gnu packages cryptsetup)
  30   #:use-module (gnu packages package-management)
  31   #:use-module (gnu packages disk)
  32   #:use-module (gnu packages grub)
  33   #:use-module (gnu packages texinfo)
  34   #:use-module (gnu packages compression)
  35   #:use-module (ice-9 match)
  36   #:use-module (srfi srfi-26)
  37   #:export (self-contained-tarball
  38             installation-os))
  39
  40 ;;; Commentary:
  41 ;;;
  42 ;;; This module provides an 'operating-system' definition for use on images
  43 ;;; for USB sticks etc., for the installation of the GNU system.
  44 ;;;
  45 ;;; Code:
  46
  47 \f
  48 (define* (self-contained-tarball #:key (guix guix))
  49   "Return a self-contained tarball containing a store initialized with the
  50 closure of GUIX.  The tarball contains /gnu/store, /var/guix, and a profile
  51 under /root/.guix-profile where GUIX is installed."
  52   (mlet %store-monad ((profile (profile-derivation
  53                                 (manifest
  54                                  (list (package->manifest-entry guix))))))
  55     (define build
  56       #~(begin
  57           (use-modules (guix build utils)
  58                        (gnu build install))
  59
  60           (define %root "root")
  61
  62           (setenv "PATH"
  63                   (string-append #$guix "/sbin:" #$tar "/bin:" #$xz "/bin"))
  64
  65           (populate-single-profile-directory %root
  66                                              #:profile #$profile
  67                                              #:closure "profile")
  68
  69           ;; Create the tarball.  Use GNU format so there's no file name
  70           ;; length limitation.  Use the owner and group names given in the
  71           ;; manual.
  72           ;; XXX: /var and /root should rather be root-owned, but it doesn't
  73           ;; make any difference in practice.
  74           (with-directory-excursion %root
  75             (zero? (system* "tar" "--xz" "--format=gnu"
  76                             "--owner=guixbuilder01"
  77                             "--group=guixbuild"
  78                             "-cvf" #$output ".")))))
  79
  80     (gexp->derivation "guix-tarball.tar.xz" build
  81                       #:references-graphs `(("profile" ,profile))
  82                       #:modules '((guix build utils)
  83                                   (guix build store-copy)
  84                                   (gnu build install)))))
  85
  86 \f
  87 (define (log-to-info)
  88   "Return a script that spawns the Info reader on the right section of the
  89 manual."
  90   (gexp->script "log-to-info"
  91                 #~(begin
  92                     ;; 'gunzip' is needed to decompress the doc.
  93                     (setenv "PATH" (string-append #$gzip "/bin"))
  94
  95                     (execl (string-append #$texinfo-4 "/bin/info") "info"
  96                            "-d" "/run/current-system/profile/share/info"
  97                            "-f" (string-append #$guix "/share/info/guix.info")
  98                            "-n" "System Installation"))))
  99
 100 (define %backing-directory
 101   ;; Sub-directory used as the backing store for copy-on-write.
 102   "/tmp/guix-inst")
 103
 104 (define (make-cow-store target)
 105   "Return a gexp that makes the store copy-on-write, using TARGET as the
 106 backing store.  This is useful when TARGET is on a hard disk, whereas the
 107 current store is on a RAM disk."
 108   (define (unionfs read-only read-write mount-point)
 109     ;; Make MOUNT-POINT the union of READ-ONLY and READ-WRITE.
 110
 111     ;; Note: in the command below, READ-WRITE appears before READ-ONLY so that
 112     ;; it is considered a "higher-level branch", as per unionfs-fuse(8),
 113     ;; thereby allowing files existing on READ-ONLY to be copied over to
 114     ;; READ-WRITE.
 115     #~(fork+exec-command
 116        (list (string-append #$unionfs-fuse "/bin/unionfs")
 117              "-o"
 118              "cow,allow_other,use_ino,max_files=65536,nonempty"
 119              (string-append #$read-write "=RW:" #$read-only "=RO")
 120              #$mount-point)))
 121
 122   (define (set-store-permissions directory)
 123     ;; Set the right perms on DIRECTORY to use it as the store.
 124     #~(begin
 125         (chown #$directory 0 30000)             ;use the fixed 'guixbuild' GID
 126         (chmod #$directory #o1775)))
 127
 128   #~(begin
 129       (unless (file-exists? "/.ro-store")
 130         (mkdir "/.ro-store")
 131         (mount #$(%store-prefix) "/.ro-store" "none"
 132                (logior MS_BIND MS_RDONLY)))
 133
 134       (let ((rw-dir (string-append target #$%backing-directory)))
 135         (mkdir-p rw-dir)
 136         (mkdir-p "/.rw-store")
 137         #$(set-store-permissions #~rw-dir)
 138         #$(set-store-permissions "/.rw-store")
 139
 140         ;; Mount the union, then atomically make it the store.
 141         (and #$(unionfs "/.ro-store" #~rw-dir "/.rw-store")
 142              (begin
 143                (sleep 1) ;XXX: wait for unionfs to be ready
 144                (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE)
 145                (rmdir "/.rw-store"))))))
 146
 147 (define (cow-store-service)
 148   "Return a service that makes the store copy-on-write, such that writes go to
 149 the user's target storage device rather than on the RAM disk."
 150   ;; See <http://bugs.gnu.org/18061> for the initial report.
 151   (with-monad %store-monad
 152     (return (service
 153              (requirement '(root-file-system user-processes))
 154              (provision '(cow-store))
 155              (documentation
 156               "Make the store copy-on-write, with writes going to \
 157 the given target.")
 158
 159              ;; This is meant to be explicitly started by the user.
 160              (auto-start? #f)
 161
 162              (start #~(case-lambda
 163                         ((target)
 164                          #$(make-cow-store #~target)
 165                          target)
 166                         (else
 167                          ;; Do nothing, and mark the service as stopped.
 168                          #f)))
 169              (stop #~(lambda (target)
 170                        ;; Delete the temporary directory, but leave everything
 171                        ;; mounted as there may still be processes using it
 172                        ;; since 'user-processes' doesn't depend on us.  The
 173                        ;; 'user-unmount' service will unmount TARGET
 174                        ;; eventually.
 175                        (delete-file-recursively
 176                         (string-append target #$%backing-directory))))))))
 177
 178 (define (configuration-template-service)
 179   "Return a dummy service whose purpose is to install an operating system
 180 configuration template file in the installation system."
 181
 182   (define search
 183     (cut search-path %load-path <>))
 184   (define templates
 185     (map (match-lambda
 186            ((file '-> target)
 187             (list (local-file (search file))
 188                   (string-append "/etc/configuration/" target))))
 189          '(("gnu/system/examples/bare-bones.tmpl" -> "bare-bones.scm")
 190            ("gnu/system/examples/desktop.tmpl" -> "desktop.scm"))))
 191
 192   (with-monad %store-monad
 193     (return (service
 194              (requirement '(root-file-system))
 195              (provision '(os-config-template))
 196              (documentation
 197               "This dummy service installs an OS configuration template.")
 198              (start #~(const #t))
 199              (stop  #~(const #f))
 200              (activate
 201               #~(begin
 202                   (use-modules (ice-9 match)
 203                                (guix build utils))
 204
 205                   (mkdir-p "/etc/configuration")
 206                   (for-each (match-lambda
 207                               ((file target)
 208                                (unless (file-exists? target)
 209                                  (copy-file file target))))
 210                             '#$templates)))))))
 211
 212 (define %nscd-minimal-caches
 213   ;; Minimal in-memory caching policy for nscd.
 214   (list (nscd-cache (database 'hosts)
 215                     (positive-time-to-live (* 3600 12))
 216                     (negative-time-to-live 20)
 217                     (persistent? #f)
 218                     (max-database-size (* 5 (expt 2 20)))))) ;5 MiB
 219
 220 (define (installation-services)
 221   "Return the list services for the installation image."
 222   (let ((motd (text-file "motd" "
 223 Welcome to the installation of the Guix System Distribution!
 224
 225 There is NO WARRANTY, to the extent permitted by law.  In particular, you may
 226 LOSE ALL YOUR DATA as a side effect of the installation process.  Furthermore,
 227 it is alpha software, so it may BREAK IN UNEXPECTED WAYS.
 228
 229 You have been warned.  Thanks for being so brave.
 230 ")))
 231     (define (normal-tty tty)
 232       (mingetty-service tty
 233                         #:motd motd
 234                         #:auto-login "root"
 235                         #:login-pause? #t))
 236
 237     (list (mingetty-service "tty1"
 238                             #:motd motd
 239                             #:auto-login "root")
 240
 241           ;; Documentation.  The manual is in UTF-8, but
 242           ;; 'console-font-service' sets up Unicode support and loads a font
 243           ;; with all the useful glyphs like em dash and quotation marks.
 244           (mingetty-service "tty2"
 245                             #:motd motd
 246                             #:auto-login "guest"
 247                             #:login-program (log-to-info))
 248
 249           ;; Documentation add-on.
 250           (configuration-template-service)
 251
 252           ;; A bunch of 'root' ttys.
 253           (normal-tty "tty3")
 254           (normal-tty "tty4")
 255           (normal-tty "tty5")
 256           (normal-tty "tty6")
 257
 258           ;; The usual services.
 259           (syslog-service)
 260
 261           ;; The build daemon.  Register the hydra.gnu.org key as trusted.
 262           ;; This allows the installation process to use substitutes by
 263           ;; default.
 264           (guix-service #:authorize-hydra-key? #t)
 265
 266           ;; Start udev so that useful device nodes are available.
 267           (udev-service)
 268
 269           ;; Add the 'cow-store' service, which users have to start manually
 270           ;; since it takes the installation directory as an argument.
 271           (cow-store-service)
 272
 273           ;; Install Unicode support and a suitable font.
 274           (console-font-service "tty1")
 275           (console-font-service "tty2")
 276           (console-font-service "tty3")
 277           (console-font-service "tty4")
 278           (console-font-service "tty5")
 279           (console-font-service "tty6")
 280
 281           ;; Since this is running on a USB stick with a unionfs as the root
 282           ;; file system, use an appropriate cache configuration.
 283           (nscd-service (nscd-configuration
 284                          (caches %nscd-minimal-caches))))))
 285
 286 (define %issue
 287   ;; Greeting.
 288   "
 289 This is an installation image of the GNU system.  Welcome.
 290
 291 Use Alt-F2 for documentation.
 292 ")
 293
 294 (define installation-os
 295   ;; The operating system used on installation images for USB sticks etc.
 296   (operating-system
 297     (host-name "gnu")
 298     (timezone "Europe/Paris")
 299     (locale "en_US.utf8")
 300     (bootloader (grub-configuration
 301                  (device "/dev/sda")))
 302     (file-systems
 303      ;; Note: the disk image build code overrides this root file system with
 304      ;; the appropriate one.
 305      (cons (file-system
 306              (mount-point "/")
 307              (device "gnu-disk-image")
 308              (type "ext4"))
 309            %base-file-systems))
 310
 311     (users (list (user-account
 312                   (name "guest")
 313                   (group "users")
 314                   (supplementary-groups '("wheel"))  ; allow use of sudo
 315                   (password "")
 316                   (comment "Guest of GNU")
 317                   (home-directory "/home/guest"))))
 318
 319     (issue %issue)
 320
 321     (services (installation-services))
 322
 323     ;; We don't need setuid programs so pass the empty list so we don't pull
 324     ;; additional programs here.
 325     (setuid-programs '())
 326
 327     (pam-services
 328      ;; Explicitly allow for empty passwords.
 329      (base-pam-services #:allow-empty-passwords? #t))
 330
 331     (packages (cons* texinfo-4                 ;for the standalone Info reader
 332                      parted ddrescue
 333                      grub                  ;mostly so xrefs to its manual work
 334                      cryptsetup
 335                      wireless-tools iw wpa-supplicant-light
 336                      ;; XXX: We used to have GNU fdisk here, but as of version
 337                      ;; 2.0.0a, that pulls Guile 1.8, which takes unreasonable
 338                      ;; space; furthermore util-linux's fdisk is already
 339                      ;; available here, so we keep that.
 340                      bash-completion
 341                      %base-packages))))
 342
 343 ;; Return it here so 'guix system' can consume it directly.
 344 installation-os
 345
 346 ;;; install.scm ends here