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
  37 ;;; Commentary:
  38 ;;;
  39 ;;; Test the installation of GuixSD using the documented approach at the
  40 ;;; command line.
  41 ;;;
  42 ;;; Code:
  43
  44 (define-os-with-source (%minimal-os %minimal-os-source)
  45   ;; The OS we want to install.
  46   (use-modules (gnu) (gnu tests) (srfi srfi-1))
  47
  48   (operating-system
  49     (host-name "liberigilo")
  50     (timezone "Europe/Paris")
  51     (locale "en_US.UTF-8")
  52
  53     (bootloader (grub-configuration (device "/dev/vdb")))
  54     (kernel-arguments '("console=ttyS0"))
  55     (file-systems (cons (file-system
  56                           (device "my-root")
  57                           (title 'label)
  58                           (mount-point "/")
  59                           (type "ext4"))
  60                         %base-file-systems))
  61     (users (cons (user-account
  62                   (name "alice")
  63                   (comment "Bob's sister")
  64                   (group "users")
  65                   (supplementary-groups '("wheel" "audio" "video"))
  66                   (home-directory "/home/alice"))
  67                  %base-user-accounts))
  68     (services (cons (service marionette-service-type
  69                              '((gnu services herd)
  70                                (guix combinators)))
  71                     %base-services))))
  72
  73 (define (operating-system-with-current-guix os)
  74   "Return a variant of OS that uses the current Guix."
  75   (operating-system
  76     (inherit os)
  77     (services (modify-services (operating-system-user-services os)
  78                 (guix-service-type config =>
  79                                    (guix-configuration
  80                                     (inherit config)
  81                                     (guix (current-guix))))))))
  82
  83 (define (operating-system-with-gc-roots os roots)
  84   "Return a variant of OS where ROOTS are registered as GC roots."
  85   (operating-system
  86     (inherit os)
  87     (services (cons (service gc-root-service-type roots)
  88                     (operating-system-user-services os)))))
  89
  90 \f
  91 (define MiB (expt 2 20))
  92
  93 (define* (run-install #:key
  94                       (os (marionette-operating-system
  95                            ;; Since the image has no network access, use the
  96                            ;; current Guix so the store items we need are in
  97                            ;; the image.
  98                            (operating-system
  99                              (inherit (operating-system-with-current-guix
 100                                        installation-os))
 101                              (kernel-arguments '("console=ttyS0")))
 102                            #:imported-modules '((gnu services herd)
 103                                                 (guix combinators))))
 104                       (target-size (* 1200 MiB)))
 105   "Run the GuixSD installation procedure from OS and return a VM image of
 106 TARGET-SIZE bytes containing the installed system."
 107
 108   (mlet* %store-monad ((_      (set-grafting #f))
 109                        (system (current-system))
 110                        (target (operating-system-derivation %minimal-os))
 111
 112                        ;; Since the installation system has no network access,
 113                        ;; we cheat a little bit by adding TARGET to its GC
 114                        ;; roots.  This way, we know 'guix system init' will
 115                        ;; succeed.
 116                        (image  (system-disk-image
 117                                 (operating-system-with-gc-roots
 118                                  os (list target))
 119                                 #:disk-image-size (* 1500 MiB))))
 120     (define install
 121       #~(begin
 122           (use-modules (guix build utils)
 123                        (gnu build marionette))
 124
 125           (set-path-environment-variable "PATH" '("bin")
 126                                          (list #$qemu-minimal))
 127
 128           (system* "qemu-img" "create" "-f" "qcow2"
 129                    #$output #$(number->string target-size))
 130
 131           (define marionette
 132             (make-marionette
 133              (cons (which #$(qemu-command system))
 134                    (cons* "-no-reboot" "-m" "800"
 135                           "-drive"
 136                           (string-append "file=" #$image
 137                                          ",if=virtio,readonly")
 138                           "-drive"
 139                           (string-append "file=" #$output ",if=virtio")
 140                           (if (file-exists? "/dev/kvm")
 141                               '("-enable-kvm")
 142                               '())))))
 143
 144           (pk 'uname (marionette-eval '(uname) marionette))
 145
 146           ;; Wait for tty1.
 147           (marionette-eval '(begin
 148                               (use-modules (gnu services herd))
 149                               (start 'term-tty1))
 150                            marionette)
 151
 152           (marionette-eval '(call-with-output-file "/etc/litl-config.scm"
 153                               (lambda (port)
 154                                 (write '#$%minimal-os-source port)))
 155                            marionette)
 156
 157           (exit (marionette-eval '(zero? (system "
 158 . /etc/profile
 159 set -e -x;
 160 guix --version
 161 guix gc --list-live | grep isc-dhcp
 162
 163 export GUIX_BUILD_OPTIONS=--no-grafts
 164 guix build isc-dhcp
 165 parted --script /dev/vdb mklabel gpt \\
 166   mkpart primary ext2 1M 3M \\
 167   mkpart primary ext2 3M 1G \\
 168   set 1 boot on \\
 169   set 1 bios_grub on
 170 mkfs.ext4 -L my-root /dev/vdb2
 171 ls -l /dev/vdb
 172 mount /dev/vdb2 /mnt
 173 df -h /mnt
 174 herd start cow-store /mnt
 175 mkdir /mnt/etc
 176 cp /etc/litl-config.scm /mnt/etc/config.scm
 177 guix system init /mnt/etc/config.scm /mnt --no-substitutes
 178 sync
 179 reboot\n"))
 180                                  marionette))))
 181
 182     (gexp->derivation "installation" install
 183                       #:modules '((guix build utils)
 184                                   (gnu build marionette)))))
 185
 186
 187 (define %test-installed-os
 188   (system-test
 189    (name "installed-os")
 190    (description
 191     "Test basic functionality of an OS installed like one would do by hand.
 192 This test is expensive in terms of CPU and storage usage since we need to
 193 build (current-guix) and then store a couple of full system images.")
 194    (value
 195     (mlet %store-monad ((image  (run-install))
 196                         (system (current-system)))
 197       (run-basic-test %minimal-os
 198                       #~(let ((image #$image))
 199                           ;; First we need a writable copy of the image.
 200                           (format #t "copying image '~a'...~%" image)
 201                           (copy-file image "disk.img")
 202                           (chmod "disk.img" #o644)
 203                           (list (string-append #$qemu-minimal "/bin/"
 204                                                #$(qemu-command system))
 205                                 "-enable-kvm" "-no-reboot" "-m" "256"
 206                                 "-drive" "file=disk.img,if=virtio"))
 207                       "installed-os")))))
 208
 209 ;;; install.scm ends here