aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016-2020, 2022-2023 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))
    (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
generated by cgit
f) ((#(_ versions modules symbols _ _ _ _ _ _) ...) (fold (lambda (version* module symbol result) (if (or (not version) (version-prefix? version version*)) (cons (module-ref (resolve-interface module) symbol) result) result)) '() versions modules symbols))) (find-packages-by-name/direct name version))) (define* (find-package-locations name #:optional version) "Return a list of version/location pairs corresponding to each package matching NAME and VERSION." (define cache (load-package-cache (current-profile))) (if (and cache (cache-is-authoritative?)) (match (cache-lookup cache name) (#f '()) ((#(name versions modules symbols outputs supported? deprecated? files lines columns) ...) (fold (lambda (version* file line column result) (if (and file (or (not version) (version-prefix? version version*))) (alist-cons version* (location file line column) result) result)) '() versions files lines columns))) (map (lambda (package) (cons (package-version package) (package-location package))) (find-packages-by-name/direct name version)))) (define (find-best-packages-by-name name version) "If version is #f, return the list of packages named NAME with the highest version numbers; otherwise, return the list of packages named NAME and at VERSION." (if version (find-packages-by-name name version) (match (find-packages-by-name name) (() '()) ((matches ...) ;; Return the subset of MATCHES with the higher version number. (let ((highest (package-version (first matches)))) (take-while (lambda (p) (string=? (package-version p) highest)) matches)))))) ;; Prevent Guile 3 from inlining this procedure so we can mock it in tests. (set! find-best-packages-by-name find-best-packages-by-name) (define (generate-package-cache directory) "Generate under DIRECTORY a cache of all the available packages. The primary purpose of the cache is to speed up package lookup by name such that we don't have to traverse and load all the package modules, thereby also reducing the memory footprint." (define cache-file (string-append directory %package-cache-file)) (define expand-cache (match-lambda* (((module symbol variable) (result . seen)) (let ((package (variable-ref variable))) (if (or (vhash-assq package seen) (hidden-package? package)) (cons result seen) (cons (cons `#(,(package-name package) ,(package-version package) ,(module-name module) ,symbol ,(package-outputs package) ,(->bool (supported-package? package)) ,(->bool (package-superseded package)) ,@(let ((loc (package-location package))) (if loc `(,(location-file loc) ,(location-line loc) ,(location-column loc)) '(#f #f #f)))) result) (vhash-consq package #t seen))))))) (define entry-key (match-lambda ((module symbol variable) (let ((value (variable-ref variable))) (string-append (package-name value) (package-version value) (object->string module) (symbol->string symbol)))))) (define (entry<? a b) (string<? (entry-key a) (entry-key b))) (define variables ;; First sort variables so that 'expand-cache' later dismisses ;; already-seen package objects in a deterministic fashion. (sort (fold-module-public-variables* (lambda (module symbol variable lst) (let ((value (false-if-exception (variable-ref variable)))) (if (package? value) (cons (list module symbol variable) lst) lst))) '() (all-modules (%package-module-path) #:warn warn-about-load-error)) entry<?)) (define exp (first (fold expand-cache (cons '() vlist-null) variables))) (mkdir-p (dirname cache-file)) (call-with-output-file cache-file (lambda (port) ;; Store the cache as a '.go' file. This makes loading fast and reduces ;; heap usage since some of the static data is directly mmapped. (match (compile `'(,@exp) #:to 'bytecode #:opts '(#:to-file? #t)) ((? bytevector? bv) (put-bytevector port bv)) (proc ;; In Guile 3.0.9, the linker can return a procedure instead of a ;; bytevector. Adjust to that. (proc port))))) cache-file) (define %sigint-prompt ;; The prompt to jump to upon SIGINT. (make-prompt-tag "interruptible")) (define (call-with-sigint-handler thunk handler) "Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal number in the context of the continuation of the call to this function, and return its return value." (call-with-prompt %sigint-prompt (lambda () (sigaction SIGINT (lambda (signum) (sigaction SIGINT SIG_DFL) (abort-to-prompt %sigint-prompt signum))) (dynamic-wind (const #t) thunk (cut sigaction SIGINT SIG_DFL))) (lambda (k signum) (handler signum)))) ;;; ;;; Package specification. ;;; (define* (%find-package spec name version) (match (find-best-packages-by-name name version) ((pkg . pkg*) (unless (null? pkg*) (warning (G_ "ambiguous package specification `~a'~%") spec) (warning (G_ "choosing ~a@~a from ~a~%") (package-name pkg) (package-version pkg) (location->string (package-location pkg)))) (match (package-superseded pkg) ((? package? new) (info (G_ "package '~a' has been superseded by '~a'~%") (package-name pkg) (package-name new)) new) (#f pkg))) (x (if version (leave (G_ "~A: package not found for version ~a~%") name version) (leave (G_ "~A: unknown package~%") name))))) (define (specification->package spec) "Return a package matching SPEC. SPEC may be a package name, or a package name followed by an at-sign and a version number. If the version number is not present, return the preferred newest version." (let ((name version (package-name->name+version spec))) (%find-package spec name version))) (define (specification->location spec) "Return the location of the highest-numbered package matching SPEC, a specification such as \"guile@2\" or \"emacs\"." (let ((name version (package-name->name+version spec))) (match (find-package-locations name version) (() (if version (leave (G_ "~A: package not found for version ~a~%") name version) (leave (G_ "~A: unknown package~%") name))) (lst (let* ((highest (match lst (((version . _) _ ...) version))) (locations (take-while (match-lambda ((version . location) (string=? version highest))) lst))) (match locations (((version . location) . rest) (unless (null? rest) (warning (G_ "ambiguous package specification `~a'~%") spec) (warning (G_ "choosing ~a@~a from ~a~%") name version (location->string location))) location))))))) (define* (specification->package+output spec #:optional (output "out")) "Return the package and output specified by SPEC, or #f and #f; SPEC may optionally contain a version number and an output name, as in these examples: guile guile@2.0.9 guile:debug guile@2.0.9:debug If SPEC does not specify a version number, return the preferred newest version; if SPEC does not specify an output, return OUTPUT. When OUTPUT is false and SPEC does not specify any output, return #f as the output." (let ((name version sub-drv (package-specification->name+version+output spec output))) (match (%find-package spec name version) (#f (values #f #f)) (package (if (or (and (not output) (not sub-drv)) (member sub-drv (package-outputs package))) (values package sub-drv) (leave (G_ "package `~a' lacks output `~a'~%") (package-full-name package) sub-drv)))))) (define (specifications->packages specs) "Given SPECS, a list of specifications such as \"emacs@25.2\" or \"guile:debug\", return a list of package/output tuples." ;; This procedure exists so users of 'guix home' don't have to write out the ;; (map (compose list specification->package+output)... boilerplate. (map (compose list specification->package+output) specs)) (define (specifications->manifest specs) "Given SPECS, a list of specifications such as \"emacs@25.2\" or \"guile:debug\", return a profile manifest." ;; This procedure exists mostly so users of 'guix package -m' don't have to ;; fiddle with multiple-value returns. (packages->manifest (specifications->packages specs))) (define (package-unique-version-prefix name version) "Search among all the versions of package NAME that are available, and return the shortest unambiguous version prefix to designate VERSION. If only one version of the package is available, return the empty string." (match (map package-version (find-packages-by-name name)) ((_) ;; A single version of NAME is available, so do not specify the version ;; number, even if the available version doesn't match VERSION. "") (versions ;; If VERSION is the latest version, don't specify any version. ;; Otherwise return the shortest unique version prefix. Note that this ;; is based on the currently available packages so the result may vary ;; over time. (if (every (cut version>? version <>) (delete version versions)) "" (version-unique-prefix version versions)))))
generated by cgit