gnu/tests/reconfigure.scm

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