gnu/tests/install.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 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 tests install)
  20   #:use-module (gnu)
  21   #:use-module (gnu tests)
  22   #:use-module (gnu tests base)
  23   #:use-module (gnu system)
  24   #:use-module (gnu system install)
  25   #:use-module (gnu system vm)
  26   #:use-module ((gnu build vm) #:select (qemu-command))
  27   #:use-module (gnu packages qemu)
  28   #:use-module (gnu packages package-management)
  29   #:use-module (guix store)
  30   #:use-module (guix monads)
  31   #:use-module (guix packages)
  32   #:use-module (guix grafts)
  33   #:use-module (guix gexp)
  34   #:use-module (guix utils)
  35   #:export (%test-installed-os
  36             %test-encrypted-os))
  37
  38 ;;; Commentary:
  39 ;;;
  40 ;;; Test the installation of GuixSD using the documented approach at the
  41 ;;; command line.
  42 ;;;
  43 ;;; Code:
  44
  45 (define-os-with-source (%minimal-os %minimal-os-source)
  46   ;; The OS we want to install.
  47   (use-modules (gnu) (gnu tests) (srfi srfi-1))
  48
  49   (operating-system
  50     (host-name "liberigilo")
  51     (timezone "Europe/Paris")
  52     (locale "en_US.UTF-8")
  53
  54     (bootloader (grub-configuration (device "/dev/vdb")))
  55     (kernel-arguments '("console=ttyS0"))
  56     (file-systems (cons (file-system
  57                           (device "my-root")
  58                           (title 'label)
  59                           (mount-point "/")
  60                           (type "ext4"))
  61                         %base-file-systems))
  62     (users (cons (user-account
  63                   (name "alice")
  64                   (comment "Bob's sister")
  65                   (group "users")
  66                   (supplementary-groups '("wheel" "audio" "video"))
  67                   (home-directory "/home/alice"))
  68                  %base-user-accounts))
  69     (services (cons (service marionette-service-type
  70                              (marionette-configuration
  71                               (imported-modules '((gnu services herd)
  72                                                   (guix combinators)))))
  73                     %base-services))))
  74
  75 (define (operating-system-with-current-guix os)
  76   "Return a variant of OS that uses the current Guix."
  77   (operating-system
  78     (inherit os)
  79     (services (modify-services (operating-system-user-services os)
  80                 (guix-service-type config =>
  81                                    (guix-configuration
  82                                     (inherit config)
  83                                     (guix (current-guix))))))))
  84
  85 (define (operating-system-with-gc-roots os roots)
  86   "Return a variant of OS where ROOTS are registered as GC roots."
  87   (operating-system
  88     (inherit os)
  89     (services (cons (service gc-root-service-type roots)
  90                     (operating-system-user-services os)))))
  91
  92 \f
  93 (define MiB (expt 2 20))
  94
  95 (define %simple-installation-script
  96   ;; Shell script of a simple installation.
  97   "\
  98 . /etc/profile
  99 set -e -x
 100 guix --version
 101
 102 export GUIX_BUILD_OPTIONS=--no-grafts
 103 guix build isc-dhcp
 104 parted --script /dev/vdb mklabel gpt \\
 105   mkpart primary ext2 1M 3M \\
 106   mkpart primary ext2 3M 1G \\
 107   set 1 boot on \\
 108   set 1 bios_grub on
 109 mkfs.ext4 -L my-root /dev/vdb2
 110 mount /dev/vdb2 /mnt
 111 df -h /mnt
 112 herd start cow-store /mnt
 113 mkdir /mnt/etc
 114 cp /etc/target-config.scm /mnt/etc/config.scm
 115 guix system init /mnt/etc/config.scm /mnt --no-substitutes
 116 sync
 117 reboot\n")
 118
 119 (define* (run-install target-os target-os-source
 120                       #:key
 121                       (script %simple-installation-script)
 122                       (os (marionette-operating-system
 123                            ;; Since the image has no network access, use the
 124                            ;; current Guix so the store items we need are in
 125                            ;; the image.
 126                            (operating-system
 127                              (inherit (operating-system-with-current-guix
 128                                        installation-os))
 129                              (kernel-arguments '("console=ttyS0")))
 130                            #:imported-modules '((gnu services herd)
 131                                                 (guix combinators))))
 132                       (target-size (* 1200 MiB)))
 133   "Run SCRIPT (a shell script following the GuixSD installation procedure) in
 134 OS to install TARGET-OS.  Return a VM image of TARGET-SIZE bytes containing
 135 the installed system."
 136
 137   (mlet* %store-monad ((_      (set-grafting #f))
 138                        (system (current-system))
 139                        (target (operating-system-derivation target-os))
 140
 141                        ;; Since the installation system has no network access,
 142                        ;; we cheat a little bit by adding TARGET to its GC
 143                        ;; roots.  This way, we know 'guix system init' will
 144                        ;; succeed.
 145                        (image  (system-disk-image
 146                                 (operating-system-with-gc-roots
 147                                  os (list target))
 148                                 #:disk-image-size (* 1500 MiB))))
 149     (define install
 150       (with-imported-modules '((guix build utils)
 151                                (gnu build marionette))
 152         #~(begin
 153             (use-modules (guix build utils)
 154                          (gnu build marionette))
 155
 156             (set-path-environment-variable "PATH" '("bin")
 157                                            (list #$qemu-minimal))
 158
 159             (system* "qemu-img" "create" "-f" "qcow2"
 160                      #$output #$(number->string target-size))
 161
 162             (define marionette
 163               (make-marionette
 164                (cons (which #$(qemu-command system))
 165                      (cons* "-no-reboot" "-m" "800"
 166                             "-drive"
 167                             (string-append "file=" #$image
 168                                            ",if=virtio,readonly")
 169                             "-drive"
 170                             (string-append "file=" #$output ",if=virtio")
 171                             (if (file-exists? "/dev/kvm")
 172                                 '("-enable-kvm")
 173                                 '())))))
 174
 175             (pk 'uname (marionette-eval '(uname) marionette))
 176
 177             ;; Wait for tty1.
 178             (marionette-eval '(begin
 179                                 (use-modules (gnu services herd))
 180                                 (start 'term-tty1))
 181                              marionette)
 182
 183             (marionette-eval '(call-with-output-file "/etc/target-config.scm"
 184                                 (lambda (port)
 185                                   (write '#$target-os-source port)))
 186                              marionette)
 187
 188             (exit (marionette-eval '(zero? (system #$script))
 189                                    marionette)))))
 190
 191     (gexp->derivation "installation" install)))
 192
 193 (define (qemu-command/writable-image image)
 194   "Return as a monadic value the command to run QEMU on a writable copy of
 195 IMAGE, a disk image."
 196   (mlet %store-monad ((system (current-system)))
 197     (return #~(let ((image #$image))
 198                 ;; First we need a writable copy of the image.
 199                 (format #t "copying image '~a'...~%" image)
 200                 (copy-file image "disk.img")
 201                 (chmod "disk.img" #o644)
 202                 `(,(string-append #$qemu-minimal "/bin/"
 203                                   #$(qemu-command system))
 204                   ,@(if (file-exists? "/dev/kvm")
 205                         '("-enable-kvm")
 206                         '())
 207                   "-no-reboot" "-m" "256"
 208                   "-drive" "file=disk.img,if=virtio")))))
 209
 210 \f
 211 (define %test-installed-os
 212   (system-test
 213    (name "installed-os")
 214    (description
 215     "Test basic functionality of an OS installed like one would do by hand.
 216 This test is expensive in terms of CPU and storage usage since we need to
 217 build (current-guix) and then store a couple of full system images.")
 218    (value
 219     (mlet* %store-monad ((image   (run-install %minimal-os %minimal-os-source))
 220                          (command (qemu-command/writable-image image)))
 221       (run-basic-test %minimal-os command
 222                       "installed-os")))))
 223
 224 \f
 225 (define-os-with-source (%encrypted-root-os %encrypted-root-os-source)
 226   ;; The OS we want to install.
 227   (use-modules (gnu) (gnu tests) (srfi srfi-1))
 228
 229   (operating-system
 230     (host-name "liberigilo")
 231     (timezone "Europe/Paris")
 232     (locale "en_US.UTF-8")
 233
 234     (bootloader (grub-configuration (device "/dev/vdb")))
 235     (kernel-arguments '("console=ttyS0"))
 236     (file-systems (cons (file-system
 237                           (device "/dev/mapper/the-root-device")
 238                           (title 'device)
 239                           (mount-point "/")
 240                           (type "ext4"))
 241                         %base-file-systems))
 242     (mapped-devices (list (mapped-device
 243                            (source "REPLACE-WITH-LUKS-UUID")
 244                            (target "the-root-device")
 245                            (type luks-device-mapping))))
 246     (users (cons (user-account
 247                   (name "charlie")
 248                   (group "users")
 249                   (home-directory "/home/charlie")
 250                   (supplementary-groups '("wheel" "audio" "video")))
 251                  %base-user-accounts))
 252     (services (cons (service marionette-service-type
 253                              (marionette-configuration
 254                               (imported-modules '((gnu services herd)
 255                                                   (guix combinators)))))
 256                     %base-services))))
 257
 258 (define %encrypted-root-installation-script
 259   ;; Shell script of a simple installation.
 260   "\
 261 . /etc/profile
 262 set -e -x
 263 guix --version
 264
 265 export GUIX_BUILD_OPTIONS=--no-grafts
 266 ls -l /run/current-system/gc-roots
 267 parted --script /dev/vdb mklabel gpt \\
 268   mkpart primary ext2 1M 3M \\
 269   mkpart primary ext2 3M 1G \\
 270   set 1 boot on \\
 271   set 1 bios_grub on
 272 echo -n thepassphrase | cryptsetup luksFormat -q /dev/vdb2 -
 273 echo -n thepassphrase | \\
 274   cryptsetup open --type luks --key-file - /dev/vdb2 the-root-device
 275 mkfs.ext4 -L my-root /dev/mapper/the-root-device
 276 mount LABEL=my-root /mnt
 277 herd start cow-store /mnt
 278 mkdir /mnt/etc
 279 cp /etc/target-config.scm /mnt/etc/config.scm
 280 cat /mnt/etc/config
 281 luks_uuid=`cryptsetup luksUUID /dev/vdb2`
 282 sed -i /mnt/etc/config.scm \\
 283     -e \"s/\\\"REPLACE-WITH-LUKS-UUID\\\"/(uuid \\\"$luks_uuid\\\")/g\"
 284 guix system build /mnt/etc/config.scm
 285 guix system init /mnt/etc/config.scm /mnt --no-substitutes
 286 sync
 287 reboot\n")
 288
 289 (define %test-encrypted-os
 290   (system-test
 291    (name "encrypted-root-os")
 292    (description
 293     "Test basic functionality of an OS installed like one would do by hand.
 294 This test is expensive in terms of CPU and storage usage since we need to
 295 build (current-guix) and then store a couple of full system images.")
 296    (value
 297     (mlet* %store-monad ((image   (run-install %encrypted-root-os
 298                                                %encrypted-root-os-source
 299                                                #:script
 300                                                %encrypted-root-installation-script))
 301                          (command (qemu-command/writable-image image)))
 302       (run-basic-test %encrypted-root-os command "encrypted-root-os")))))
 303
 304 ;;; install.scm ends here