aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016-2020, 2022-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu tests)
  #:use-module (guix gexp)
  #:use-module (guix diagnostics)
  #:use-module (guix records)
  #:use-module ((guix ui) #:select (warn-about-load-error))
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader grub)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system shadow)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services shepherd)
  #:use-module (guix discovery)
  #:use-module (guix monads)
  #:use-module ((guix store) #:select (%store-monad))
  #:use-module ((guix utils)
                #:select (%current-system %current-target-system))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (ice-9 match)
  #:export (marionette-configuration
            marionette-configuration?
            marionette-configuration-device
            marionette-configuration-imported-modules
            marionette-configuration-requirements

            marionette-service-type
            marionette-operating-system
            define-os-with-source

            %simple-os
            simple-operating-system

            system-test
            system-test?
            system-test-name
            system-test-value
            system-test-description
            system-test-location

            fold-system-tests
            all-system-tests))

;;; Commentary:
;;;
;;; This module provides the infrastructure to run operating system tests.
;;; The most important part of that is tools to instrument the OS under test,
;;; essentially allowing it to run in a virtual machine controlled by the host
;;; system--hence the name "marionette".
;;;
;;; Code:

(define-record-type* <marionette-configuration>
  marionette-configuration make-marionette-configuration
  marionette-configuration?
  (device           marionette-configuration-device ;string
                    (default "/dev/virtio-ports/org.gnu.guix.port.0"))
  (imported-modules marionette-configuration-imported-modules
                    (default '()))
  (extensions       marionette-configuration-extensions
                    (default '())) ; list of packages
  (requirements     marionette-configuration-requirements ;list of symbols
                    (default '())))

;; Hack: avoid indenting code beyond column 80 in marionette-shepherd-service.
(define-syntax-rule (with-imported-modules-and-extensions imported-modules
                                                          extensions
                                                          gexp)
  (with-imported-modules imported-modules
    (with-extensions extensions
      gexp)))

(define (marionette-program device imported-modules extensions)
  "Return the program that runs the marionette REPL on DEVICE.  Ensure
IMPORTED-MODULES and EXTENSIONS are accessible from the REPL."
  (define code
    (with-imported-modules-and-extensions
        `((guix build utils)
          (guix build syscalls)
          ,@imported-modules)
        extensions
      #~(begin
          (use-modules (ice-9 match)
                       (ice-9 binary-ports))

          (define (self-quoting? x)
            (letrec-syntax ((one-of (syntax-rules ()
                                      ((_) #f)
                                      ((_ pred rest ...)
                                       (or (pred x)
                                           (one-of rest ...))))))
              (one-of symbol? string? keyword? pair? null? array?
                      number? boolean? char?)))

          (let ((repl    (open-file #$device "r+0"))
                (console (open-file "/dev/console" "r+0")))
            ;; Redirect output to the console.
            (close-fdes 1)
            (close-fdes 2)
            (dup2 (fileno console) 1)
            (dup2 (fileno console) 2)
            (close-port console)

            (display 'ready repl)
            (let loop ()
              (newline repl)

              (match (read repl)
                ((? eof-object?)
                 (primitive-exit 0))
                (expr
                 (catch #t
                   (lambda ()
                     (let ((result (primitive-eval expr)))
                       (write (if (self-quoting? result)
                                  result
                                  (object->string result))
                              repl)))
                   (lambda (key . args)
                     (print-exception (current-error-port)
                                      (stack-ref (make-stack #t) 1)
                                      key args)
                     (write #f repl)))))
              (loop))))))

  (program-file "marionette-repl.scm" code))

(define (marionette-shepherd-service config)
  "Return the Shepherd service for the marionette REPL"
  (match config
    (($ <marionette-configuration> device imported-modules extensions
                                   requirement)
     (list (shepherd-service
            (provision '(marionette))

            ;; Always depend on UDEV so that DEVICE is available.
            (requirement `(udev ,@requirement))

            (modules '((ice-9 match)
                       (srfi srfi-9 gnu)))
            (start #~(make-forkexec-constructor
                      (list #$(marionette-program device
                                                  imported-modules
                                                  extensions))))
            (stop #~(make-kill-destructor)))))))

(define marionette-service-type
  ;; This is the type of the "marionette" service, allowing a guest system to
  ;; be manipulated from the host.  This marionette REPL is essentially a
  ;; universal backdoor.
  (service-type (name 'marionette-repl)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          marionette-shepherd-service)))
                (description "The @dfn{marionette} service allows a guest
system (virtual machine) to be manipulated by the host.  It is used for system
tests.")))

(define* (marionette-operating-system os
                                      #:key
                                      (imported-modules '())
                                      (extensions '())
                                      (requirements '()))
  "Return a marionetteed variant of OS such that OS can be used as a
marionette in a virtual machine--i.e., controlled from the host system.  The
marionette service in the guest is started after the Shepherd services listed
in REQUIREMENTS.  The packages in the list EXTENSIONS are made available from
the backdoor REPL."
  (operating-system
    (inherit os)
    ;; Make sure the guest dies on error.
    (kernel-arguments (cons "panic=1"
                            (operating-system-user-kernel-arguments os)))
    ;; Make sure the guest doesn't hang in the REPL on error.
    (initrd (lambda (fs . rest)
              (apply (operating-system-initrd os) fs
                     #:on-error 'backtrace
                     rest)))
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (requirements requirements)
                              (extensions extensions)
                              (imported-modules imported-modules)))
                    (operating-system-user-services os)))))

(define-syntax define-os-with-source
  (syntax-rules (use-modules operating-system)
    "Define two variables: OS containing the given operating system, and
SOURCE containing the source to define OS as an sexp.

This is convenient when we need both the <operating-system> object so we can
instantiate it, and the source to create it so we can store in in a file in
the system under test."
    ((_ (os source)
        (use-modules modules ...)
        (operating-system fields ...))
     (begin
       (define os
         (operating-system fields ...))
       (define source
         '(begin
            (use-modules modules ...)
            (operating-system fields ...)))))))


;;;
;;; Simple operating systems.
;;;

(define %simple-os
  (operating-system
    (host-name "komputilo")
    (timezone "Europe/Berlin")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (targets '("/dev/sdX"))))
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (kernel-arguments (delete "quiet" %default-kernel-arguments))
    (firmware '())

    (users (cons (user-account
                  (name "alice")
                  (comment "Bob's sister")
                  (group "users")
                  (supplementary-groups '("wheel" "audio" "video")))
                 %base-user-accounts))))

(define-syntax-rule (simple-operating-system user-services ...)
  "Return an operating system that includes USER-SERVICES in addition to
%BASE-SERVICES."
  (operating-system (inherit %simple-os)
                    (services (cons* user-services ... %base-services))))



;;;
;;; Tests.
;;;

(define-record-type* <system-test> system-test make-system-test
  system-test?
  (name        system-test-name)                  ;string
  (value       system-test-value)                 ;%STORE-MONAD value
  (description system-test-description)           ;string
  (location    system-test-location (innate)      ;<location>
               (default (and=> (current-source-location)
                               source-properties->location))))

(define (write-system-test test port)
  (match test
    (($ <system-test> name _ _ ($ <location> file line))
     (format port "#<system-test ~a ~a:~a ~a>"
             name file line
             (number->string (object-address test) 16)))
    (($ <system-test> name)
     (format port "#<system-test ~a ~a>" name
             (number->string (object-address test) 16)))))

(set-record-type-printer! <system-test> write-system-test)

(define-gexp-compiler (compile-system-test (test <system-test>)
                                           system target)
  "Compile TEST to a derivation."
  (mparameterize %store-monad ((%current-system system)
                               (%current-target-system target))
    (system-test-value test)))

(define (test-modules)
  "Return the list of modules that define system tests."
  (scheme-modules (dirname (search-path %load-path "guix.scm"))
                  "gnu/tests"
                  #:warn warn-about-load-error))

(define (fold-system-tests proc seed)
  "Invoke PROC on each system test, passing it the test and the previous
result."
  (fold-module-public-variables (lambda (obj result)
                                  (if (system-test? obj)
                                      (cons obj result)
                                      result))
                                '()
                                (test-modules)))

(define (all-system-tests)
  "Return the list of system tests."
  (reverse (fold-system-tests cons '())))


;; Local Variables:
;; eval: (put 'with-imported-modules-and-extensions 'scheme-indent-function 2)
;; End:

;;; tests.scm ends here
msg-tooltip'>* build-aux/build-self.scm (build): Change #:guile-version to default to "2.2" when PULL-VERSION is greater than 0. Ludovic Courtès 2018-07-27gnu: guile: Remove version 2.2.2....* gnu/packages/guile.scm (guile-2.2.2): Remove. * guix/self.scm (guile-for-build): Remove special case for "2.2.2". (guix-derivation): Likewise. * build-aux/build-self.scm (build): Likewise. Ludovic Courtès 2018-06-26build-self: Inherit the daemon connection from the parent process....Fixes <https://bugs.gnu.org/31892>. Reported by Vagrant Cascadian <vagrant@debian.org>. * build-aux/build-self.scm (build): Define 'port' and wrap 'open-pipe*' call in 'with-input-from-port'. (build-program): Use 'port->connection' or 'open-connection' instead of 'with-store.' Ludovic Courtès 2018-06-21build-self: Avoid recompilations of 'compute-guix-derivation'....* build-aux/build-self.scm (build-program)["compute-guix-derivation"]: Honor the SOURCE command-line argument. Add a VERSION command-line argument and honor it. (build): Pass VERSION to BUILD. Ludovic Courtès 2018-06-18self: Define derived '-directory' variables in config.scm....This is a followup to d6b5aa0b031f0e7091f7424ac616d1c4d10fed5b. * guix/self.scm (%config-variables): Remove %CONFIG-DIRECTORY, %STATE-DIRECTORY, %STORE-DATABASE-DIRECTORY, and %STORE-DIRECTORY. (make-config.scm): Define them here. * build-aux/build-self.scm (%config-variables, make-config.scm): Likewise. Ludovic Courtès 2018-06-18build-self: Do not rely on '%store-database-directory'....Guix'es older than one week don't have this variable so requiring it would break things for them. * build-aux/build-self.scm (%config-variables): Remove '%store-database-directory'. Ludovic Courtès 2018-06-18build: Remove checks for 'nix-instantiate'....* guix/import/snix.scm (open-nixpkgs): Use "nix-instantiate" unconditionally. * configure.ac: Remove check for 'nix-instantiate'. * guix/config.scm.in (%nix-instantiate): Remove. * guix/self.scm (%dependency-variables): Remove '%nix-instantiate'. (make-config.scm): Remove it from the generated "config.scm". * build-aux/build-self.scm (%dependency-variables, make-config.scm): Likewise. Ludovic Courtès 2018-06-18self: Make (guix config) generation really stateless....Previously the %CONFIG-VARIABLES list would be generated based on what the current (guix config) contains. Thus, it would include '%guix-register-program', which we recently removed, because existing (guix config) most likely contained that variable. Since its value could differ from machine to machine, the build farm could be building a different config.scm, thereby preventing people from getting substitutes. * guix/self.scm (%config-variables): Turn into a white list instead of taking all the remaining variables from the current (guix config). * build-aux/build-self.scm (%config-variables): Likewise. Ludovic Courtès 2018-06-09self: Produce a complete package with the 'guix' command....* guix/self.scm (guix-command): New procedure. (compiled-guix): Add #:pull-version parameter. [command, package]: New variables. Honor PULL-VERSION. (guix-derivation): Add #:pull-version and pass it to 'compiled-guix'. * build-aux/build-self.scm (build-program): Add #:pull-version parameter. Pass it to 'guix-derivation'. (build): Add #:pull-version and pass it to 'build-program'. * build-aux/compile-as-derivation.scm: Pass #:pull-version to BUILD. Ludovic Courtès 2018-04-08build-self: Add missing 'close-pipe' call....* build-aux/build-self.scm (build): Call 'close-pipe'. Ludovic Courtès 2018-04-08build-self: Use (guix self)....This mitigates <https://bugs.gnu.org/27284>. * build-aux/build-self.scm (libgcrypt, zlib, gzip, bzip2, xz) (false-if-wrong-guile, package-for-current-guile, guile-json) (guile-ssh, guile-git, guile-bytestructures, matching-guile-2.2): Remove. (%dependency-variables, %persona-variables, %config-variables): New variables. (make-config.scm, load-path-expression, gexp->script) (build-program): New procedures. (build): Rewrite to simply delegate to 'guix-derivation'. Ludovic Courtès 2018-02-15pull: Update the %sbindir variable in (guix config) when building....Fixes <https://bugs.gnu.org/30370>. * build-aux/build-self.scm (guix): New variable. (builder): Use it. Signed-off-by: Ludovic Courtès <ludo@gnu.org> Diego Nicola Barbato 2017-12-13pull: Add (guix profiling) to the build environment....Reported by Ricardo Wurmus. * build-aux/build-self.scm (build): Add (guix profiling). Ludovic Courtès 2017-12-07pull: Build with an ABI-compatible Guile....Fixes <https://bugs.gnu.org/29570>. Reported by Vagrant Cascadian <vagrant@debian.org>. * build-aux/build-self.scm (matching-guile-2.2): New procedure. (guile-for-build): Use it. Ludovic Courtès 2017-11-21Revert "Add (guix self) and use it when pulling."...This reverts commit 5f93d97005897c2d859f0be1bdff34c88467ec61. 'guix pull' would fail because (guix self) needs 'scheme-files' from (guix discovery), which was not exported until now. Ludovic Courtès 2017-11-21Add (guix self) and use it when pulling....This mitigates <https://bugs.gnu.org/27284>. * guix/self.scm: New file. * Makefile.am (MODULES): Add it. * build-aux/build-self.scm (libgcrypt, zlib, gzip, bzip2, xz) (false-if-wrong-guile, package-for-current-guile, guile-json) (guile-ssh, guile-git, guile-bytestructures): Remove. (build): Rewrite to simply delegate to 'compiled-guix'. * gnu/packages.scm (%distro-root-directory): Rewrite to try different directories. * guix/discovery.scm (guix): Export 'scheme-files'. * guix/scripts/pull.scm (build-and-install): Split into... (install-latest): ... this. New procedure. And... (build-and-install): ... this, which now takes a monadic value argument. (indirect-root-added): Remove. (guix-pull): Call 'add-indirect-root'. Call 'build-from-source' and pass the result to 'build-and-install'. Ludovic Courtès 2017-10-23pull: Add (guix build compile) to the mix....Fixes <https://bugs.gnu.org/28956>. Reported by Leo Famulari <leo@famulari.name>. * build-aux/build-self.scm (build): Add (guix build compile) to #:modules. * guix/build/pull.scm (build-guix): Wrap 'compile-files' call in 'with-directory-excursion'. Strip "./" from FILES when passing it to 'compile-files'. Ludovic Courtès 2017-08-02pull: Fetch source code from Git....* guix/scripts/pull.scm (%snapshot-url, with-environment-variable) (with-PATH): Remove. (ensure-guile-git!): New procedure. (%repository-url): New variable. (%default-options): Add 'repository-url' and 'ref'. (show-help, %options): Add '--commit' and '--url'. (temporary-directory, first-directory, interned-then-deleted) (unpack): Remove. (build-from-source): Rename 'tarball' to 'source'. Remove call to 'unpack'. (build-and-install): Rename 'tarball' to 'source'. (honor-lets-encrypt-certificates!, report-git-error): New procedures. (with-git-error-handling): New macro. (guix-pull)[fetch-tarball]: Remove. Wrap body in 'with-git-error-handling'. Rewrite to use 'latest-repository-commit'. * build-aux/build-self.scm (build): Print an error message and exit when GUILE-GIT is #f. * doc/guix.texi (Invoking guix pull): Mention Git. Document '--commit' and '--branch'. Ludovic Courtès 2017-06-09pull: Add a dependency to guile-git....* build-aux/build-self.scm (guile-git, guile-bytestructures): New variables. (build): Add guile-git and guile-bytestructures to %load-path and %load-compiled-path. Mathieu Othacehe 2017-05-09pull: Build with the matching Guile major version....Previously, 'guix pull' would always build with Guile 2.0. Now it builds with the Guile that matches (effective-version). * build-aux/build-self.scm (false-if-wrong-guile) (package-for-current-guile): New procedures. (guile-json, guile-ssh): Use it. (guile-for-build): New procedure. (build): Use (effective-version) instead of the hard-coded "/2.0". Add (guix modules) closure to #:modules argument. Pass \#:guile-for-build argument to 'gexp->derivation'. * guix/build/pull.scm (depends-on-guile-ssh?, all-scheme-files): New procedures. (build-guix): Show the output of (version). Use the above procedures. Filter out files that match 'depends-on-guile-ssh?' when (ssh session) is missing. Ludovic Courtès 2016-11-27pull: Hack to allow compilation with older Guile-SSH packages....Reported by iyzsong@member.fsf.org (宋文武) at <https://lists.gnu.org/archive/html/guix-devel/2016-11/msg01045.html>. * build-aux/build-self.scm (build): Set 'LTDL_LIBRARY_PATH' when GUILE-SSH has a "0.9." version prefix. Ludovic Courtès 2016-11-26pull: Add guile-ssh to the dependencies....Fix regression introduced in 9e76eed. * build-aux/build-self.scm (guile-ssh): New variable. (build)[builder]: Add 'guile-ssh' to %load-path and %load-compiled-path. 宋文武 2016-07-20pull: Update the version string....Fixes <http://bugs.gnu.org/19278>. Reported by Tomáš Čech <tcech@suse.cz>. This allows 'guix --version' to return something that better represents what version is being used. * build-aux/build-self.scm (date-version-string): New procedure. (build): Add #:version. [builder]: Pass it to 'build-guix' as #:package-version. Ludovic Courtès 2016-07-20pull: Install (guix config) module to override the user's one....* build-aux/build-self.scm (zlib, gzip, bzip2, xz): New variables. (build)[storedir, localstatedir, sysconfdir, sbindir]: New variables. [builder]: Pass them to 'build-guix'. * guix/build/pull.scm (build-guix): Add #:system, #:storedir, #:localstatedir, #:sysconfdir, #:sbindir, #:package-name, #:package-version, #:bug-report-address, #:home-page-url, #:libgcrypt, #:zlib, #:gzip, #:bzip2, and #:xz. Remove #:gcrypt. Instantiate all the substitution variables in (guix config). Remove code to delete OUT/guix/config.{scm,go}. * guix/config.scm.in: Add note about (guix script pull). Ludovic Courtès