gnu/tests/reconfigure.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.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 reconfigure)
  20   #:use-module (gnu bootloader)
  21   #:use-module (gnu services shepherd)
  22   #:use-module (gnu system vm)
  23   #:use-module (gnu system)
  24   #:use-module (gnu tests)
  25   #:use-module (guix derivations)
  26   #:use-module (guix gexp)
  27   #:use-module (guix monads)
  28   #:use-module (guix scripts system reconfigure)
  29   #:use-module (guix store)
  30   #:export (%test-switch-to-system
  31             %test-upgrade-services
  32             %test-install-bootloader))
  33
  34 ;;; Commentary:
  35 ;;;
  36 ;;; Test in-place system reconfiguration: advancing the system generation on a
  37 ;;; running instance of the Guix System.
  38 ;;;
  39 ;;; Code:
  40
  41 (define* (run-switch-to-system-test)
  42   "Run a test of an OS running SWITCH-SYSTEM-PROGRAM, which creates a new
  43 generation of the system profile."
  44   (define os
  45     (marionette-operating-system
  46      (simple-operating-system)
  47      #:imported-modules '((gnu services herd)
  48                           (guix combinators))))
  49
  50   (define vm (virtual-machine os))
  51
  52   (define (test script)
  53     (with-imported-modules '((gnu build marionette))
  54       #~(begin
  55           (use-modules (gnu build marionette)
  56                        (srfi srfi-64))
  57
  58           (define marionette
  59             (make-marionette (list #$vm)))
  60
  61           ;; Return the names of the generation symlinks on MARIONETTE.
  62           (define (system-generations marionette)
  63             (marionette-eval
  64              '(begin
  65                 (use-modules (ice-9 ftw)
  66                              (srfi srfi-1))
  67                 (let* ((profile-dir "/var/guix/profiles/")
  68                        (entries (map first (cddr (file-system-tree profile-dir)))))
  69                   (remove (lambda (entry)
  70                             (member entry '("per-user" "system")))
  71                           entries)))
  72              marionette))
  73
  74           (mkdir #$output)
  75           (chdir #$output)
  76
  77           (test-begin "switch-to-system")
  78
  79           (let ((generations-prior (system-generations marionette)))
  80             (test-assert "script successfully evaluated"
  81               (marionette-eval
  82                '(primitive-load #$script)
  83                marionette))
  84
  85             (test-equal "script created new generation"
  86               (length (system-generations marionette))
  87               (1+ (length generations-prior))))
  88
  89           (test-end)
  90           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
  91
  92   (gexp->derivation "switch-to-system" (test (switch-system-program os))))
  93
  94 (define* (run-upgrade-services-test)
  95   "Run a test of an OS running UPGRADE-SERVICES-PROGRAM, which upgrades the
  96 Shepherd (PID 1) by unloading obsolete services and loading new services."
  97   (define os
  98     (marionette-operating-system
  99      (simple-operating-system)
 100      #:imported-modules '((gnu services herd)
 101                           (guix combinators))))
 102
 103   (define vm (virtual-machine os))
 104
 105   (define dummy-service
 106     ;; Shepherd service that does nothing, for the sole purpose of ensuring
 107     ;; that it is properly installed and started by the script.
 108     (shepherd-service (provision '(dummy))
 109                       (start #~(const #t))
 110                       (stop #~(const #t))
 111                       (respawn? #f)))
 112
 113   ;; Return the Shepherd service file for SERVICE, after ensuring that it
 114   ;; exists in the store.
 115   (define (ensure-service-file service)
 116     (let ((file (shepherd-service-file service)))
 117       (mlet* %store-monad ((store-object (lower-object file))
 118                            (_ (built-derivations (list store-object))))
 119         (return file))))
 120
 121   (define (test enable-dummy disable-dummy)
 122     (with-imported-modules '((gnu build marionette))
 123       #~(begin
 124           (use-modules (gnu build marionette)
 125                        (srfi srfi-64))
 126
 127           (define marionette
 128             (make-marionette (list #$vm)))
 129
 130           ;; Return the names of the running services on MARIONETTE.
 131           (define (running-services marionette)
 132             (marionette-eval
 133              '(begin
 134                 (use-modules (gnu services herd))
 135                 (map live-service-canonical-name (current-services)))
 136              marionette))
 137
 138           (mkdir #$output)
 139           (chdir #$output)
 140
 141           (test-begin "upgrade-services")
 142
 143           (let ((services-prior (running-services marionette)))
 144             (test-assert "script successfully evaluated"
 145               (marionette-eval
 146                '(primitive-load #$enable-dummy)
 147                marionette))
 148
 149             (test-assert "script started new service"
 150               (and (not (memq 'dummy services-prior))
 151                    (memq 'dummy (running-services marionette))))
 152
 153             (test-assert "script successfully evaluated"
 154               (marionette-eval
 155                '(primitive-load #$disable-dummy)
 156                marionette))
 157
 158             (test-assert "script stopped obsolete service"
 159               (not (memq 'dummy (running-services marionette)))))
 160
 161           (test-end)
 162           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 163
 164   (mlet* %store-monad ((file (ensure-service-file dummy-service)))
 165     (let ((enable (upgrade-services-program (list file) '(dummy) '() '()))
 166           (disable (upgrade-services-program '() '() '(dummy) '())))
 167       (gexp->derivation "upgrade-services" (test enable disable)))))
 168
 169 (define* (run-install-bootloader-test)
 170   "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a
 171 bootloader's configuration file."
 172   (define os
 173     (marionette-operating-system
 174      (simple-operating-system)
 175      #:imported-modules '((gnu services herd)
 176                           (guix combinators))))
 177
 178   (define vm (virtual-machine os))
 179
 180   (define (test script)
 181     (with-imported-modules '((gnu build marionette))
 182       #~(begin
 183           (use-modules (gnu build marionette)
 184                        (ice-9 regex)
 185                        (srfi srfi-1)
 186                        (srfi srfi-64))
 187
 188           (define marionette
 189             (make-marionette (list #$vm)))
 190
 191           ;; Return the system generation paths that have GRUB menu entries.
 192           (define (generations-in-grub-cfg marionette)
 193             (let ((grub-cfg (marionette-eval
 194                              '(begin
 195                                 (call-with-input-file "/boot/grub/grub.cfg"
 196                                   (lambda (port)
 197                                     (get-string-all port))))
 198                              marionette)))
 199               (map (lambda (parameter)
 200                      (second (string-split (match:substring parameter) #\=)))
 201                    (list-matches "system=[^ ]*" grub-cfg))))
 202
 203           (mkdir #$output)
 204           (chdir #$output)
 205
 206           (test-begin "install-bootloader")
 207
 208           (test-assert "no prior menu entry for system generation"
 209             (not (member #$os (generations-in-grub-cfg marionette))))
 210
 211           (test-assert "script successfully evaluated"
 212             (marionette-eval
 213              '(primitive-load #$script)
 214              marionette))
 215
 216           (test-assert "menu entry created for system generation"
 217             (member #$os (generations-in-grub-cfg marionette)))
 218
 219           (test-end)
 220           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 221
 222   (let* ((bootloader ((compose bootloader-configuration-bootloader
 223                                operating-system-bootloader)
 224                       os))
 225          ;; The typical use-case for 'install-bootloader-program' is to read
 226          ;; the boot parameters for the existing menu entries on the system,
 227          ;; parse them with 'boot-parameters->menu-entry', and pass the
 228          ;; results to 'operating-system-bootcfg'. However, to obtain boot
 229          ;; parameters, we would need to start the marionette, which we should
 230          ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we
 231          ;; generate a bootloader configuration for the script as if there
 232          ;; were no existing menu entries. In the grand scheme of things, this
 233          ;; matters little -- these tests should not make assertions about the
 234          ;; behavior of 'operating-system-bootcfg'.
 235          (bootcfg (operating-system-bootcfg os '()))
 236          (bootcfg-file (bootloader-configuration-file bootloader)))
 237     (gexp->derivation
 238      "install-bootloader"
 239      ;; Due to the read-only nature of the virtual machines used in the system
 240      ;; test suite, the bootloader installer script is omitted. 'grub-install'
 241      ;; would attempt to write directly to the virtual disk if the
 242      ;; installation script were run.
 243      (test (install-bootloader-program #f #f bootcfg bootcfg-file #f "/")))))
 244
 245 (define %test-switch-to-system
 246   (system-test
 247    (name "switch-to-system")
 248    (description "Create a new generation of the system profile.")
 249    (value (run-switch-to-system-test))))
 250
 251 (define %test-upgrade-services
 252   (system-test
 253    (name "upgrade-services")
 254    (description "Upgrade the Shepherd by unloading obsolete services and
 255 loading new services.")
 256    (value (run-upgrade-services-test))))
 257
 258 (define %test-install-bootloader
 259   (system-test
 260    (name "install-bootloader")
 261    (description "Install a bootloader and its configuration file.")
 262    (value (run-install-bootloader-test))))