gnu/system/install.scm

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