You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

283 lines
11 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
  4. ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
  5. ;;;
  6. ;;; This file is part of GNU Guix.
  7. ;;;
  8. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; GNU Guix is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (gnu tests)
  21. #:use-module (guix gexp)
  22. #:use-module (guix utils)
  23. #:use-module (guix records)
  24. #:use-module ((guix ui) #:select (warn-about-load-error))
  25. #:use-module (gnu bootloader)
  26. #:use-module (gnu bootloader grub)
  27. #:use-module (gnu system)
  28. #:use-module (gnu system file-systems)
  29. #:use-module (gnu system shadow)
  30. #:use-module (gnu services)
  31. #:use-module (gnu services base)
  32. #:use-module (gnu services shepherd)
  33. #:use-module (guix discovery)
  34. #:use-module (srfi srfi-1)
  35. #:use-module (srfi srfi-9 gnu)
  36. #:use-module (ice-9 match)
  37. #:export (marionette-configuration
  38. marionette-configuration?
  39. marionette-configuration-device
  40. marionette-configuration-imported-modules
  41. marionette-configuration-requirements
  42. marionette-service-type
  43. marionette-operating-system
  44. define-os-with-source
  45. simple-operating-system
  46. system-test
  47. system-test?
  48. system-test-name
  49. system-test-value
  50. system-test-description
  51. system-test-location
  52. fold-system-tests
  53. all-system-tests))
  54. ;;; Commentary:
  55. ;;;
  56. ;;; This module provides the infrastructure to run operating system tests.
  57. ;;; The most important part of that is tools to instrument the OS under test,
  58. ;;; essentially allowing it to run in a virtual machine controlled by the host
  59. ;;; system--hence the name "marionette".
  60. ;;;
  61. ;;; Code:
  62. (define-record-type* <marionette-configuration>
  63. marionette-configuration make-marionette-configuration
  64. marionette-configuration?
  65. (device marionette-configuration-device ;string
  66. (default "/dev/virtio-ports/org.gnu.guix.port.0"))
  67. (imported-modules marionette-configuration-imported-modules
  68. (default '()))
  69. (requirements marionette-configuration-requirements ;list of symbols
  70. (default '())))
  71. (define (marionette-shepherd-service config)
  72. "Return the Shepherd service for the marionette REPL"
  73. (match config
  74. (($ <marionette-configuration> device imported-modules requirement)
  75. (list (shepherd-service
  76. (provision '(marionette))
  77. ;; Always depend on UDEV so that DEVICE is available.
  78. (requirement `(udev ,@requirement))
  79. (modules '((ice-9 match)
  80. (srfi srfi-9 gnu)))
  81. (start
  82. (with-imported-modules imported-modules
  83. #~(lambda ()
  84. (define (self-quoting? x)
  85. (letrec-syntax ((one-of (syntax-rules ()
  86. ((_) #f)
  87. ((_ pred rest ...)
  88. (or (pred x)
  89. (one-of rest ...))))))
  90. (one-of symbol? string? keyword? pair? null? array?
  91. number? boolean? char?)))
  92. (match (primitive-fork)
  93. (0
  94. (dynamic-wind
  95. (const #t)
  96. (lambda ()
  97. (let ((repl (open-file #$device "r+0"))
  98. (console (open-file "/dev/console" "r+0")))
  99. ;; Redirect output to the console.
  100. (close-fdes 1)
  101. (close-fdes 2)
  102. (dup2 (fileno console) 1)
  103. (dup2 (fileno console) 2)
  104. (close-port console)
  105. (display 'ready repl)
  106. (let loop ()
  107. (newline repl)
  108. (match (read repl)
  109. ((? eof-object?)
  110. (primitive-exit 0))
  111. (expr
  112. (catch #t
  113. (lambda ()
  114. (let ((result (primitive-eval expr)))
  115. (write (if (self-quoting? result)
  116. result
  117. (object->string result))
  118. repl)))
  119. (lambda (key . args)
  120. (print-exception (current-error-port)
  121. (stack-ref (make-stack #t) 1)
  122. key args)
  123. (write #f repl)))))
  124. (loop))))
  125. (lambda ()
  126. (primitive-exit 1))))
  127. (pid
  128. pid)))))
  129. (stop #~(make-kill-destructor)))))))
  130. (define marionette-service-type
  131. ;; This is the type of the "marionette" service, allowing a guest system to
  132. ;; be manipulated from the host. This marionette REPL is essentially a
  133. ;; universal backdoor.
  134. (service-type (name 'marionette-repl)
  135. (extensions
  136. (list (service-extension shepherd-root-service-type
  137. marionette-shepherd-service)))))
  138. (define* (marionette-operating-system os
  139. #:key
  140. (imported-modules '())
  141. (requirements '()))
  142. "Return a marionetteed variant of OS such that OS can be used as a
  143. marionette in a virtual machine--i.e., controlled from the host system. The
  144. marionette service in the guest is started after the Shepherd services listed
  145. in REQUIREMENTS."
  146. (operating-system
  147. (inherit os)
  148. ;; Make sure the guest dies on error.
  149. (kernel-arguments (cons "panic=1"
  150. (operating-system-user-kernel-arguments os)))
  151. ;; Make sure the guest doesn't hang in the REPL on error.
  152. (initrd (lambda (fs . rest)
  153. (apply (operating-system-initrd os) fs
  154. #:on-error 'backtrace
  155. rest)))
  156. (services (cons (service marionette-service-type
  157. (marionette-configuration
  158. (requirements requirements)
  159. (imported-modules imported-modules)))
  160. (operating-system-user-services os)))))
  161. (define-syntax define-os-with-source
  162. (syntax-rules (use-modules operating-system)
  163. "Define two variables: OS containing the given operating system, and
  164. SOURCE containing the source to define OS as an sexp.
  165. This is convenient when we need both the <operating-system> object so we can
  166. instantiate it, and the source to create it so we can store in in a file in
  167. the system under test."
  168. ((_ (os source)
  169. (use-modules modules ...)
  170. (operating-system fields ...))
  171. (begin
  172. (define os
  173. (operating-system fields ...))
  174. (define source
  175. '(begin
  176. (use-modules modules ...)
  177. (operating-system fields ...)))))))
  178. ;;;
  179. ;;; Simple operating systems.
  180. ;;;
  181. (define %simple-os
  182. (operating-system
  183. (host-name "komputilo")
  184. (timezone "Europe/Berlin")
  185. (locale "en_US.UTF-8")
  186. (bootloader (bootloader-configuration
  187. (bootloader grub-bootloader)
  188. (target "/dev/sdX")))
  189. (file-systems (cons (file-system
  190. (device (file-system-label "my-root"))
  191. (mount-point "/")
  192. (type "ext4"))
  193. %base-file-systems))
  194. (firmware '())
  195. (users (cons (user-account
  196. (name "alice")
  197. (comment "Bob's sister")
  198. (group "users")
  199. (supplementary-groups '("wheel" "audio" "video")))
  200. %base-user-accounts))))
  201. (define-syntax-rule (simple-operating-system user-services ...)
  202. "Return an operating system that includes USER-SERVICES in addition to
  203. %BASE-SERVICES."
  204. (operating-system (inherit %simple-os)
  205. (services (cons* user-services ... %base-services))))
  206. ;;;
  207. ;;; Tests.
  208. ;;;
  209. (define-record-type* <system-test> system-test make-system-test
  210. system-test?
  211. (name system-test-name) ;string
  212. (value system-test-value) ;%STORE-MONAD value
  213. (description system-test-description) ;string
  214. (location system-test-location (innate) ;<location>
  215. (default (and=> (current-source-location)
  216. source-properties->location))))
  217. (define (write-system-test test port)
  218. (match test
  219. (($ <system-test> name _ _ ($ <location> file line))
  220. (format port "#<system-test ~a ~a:~a ~a>"
  221. name file line
  222. (number->string (object-address test) 16)))
  223. (($ <system-test> name)
  224. (format port "#<system-test ~a ~a>" name
  225. (number->string (object-address test) 16)))))
  226. (set-record-type-printer! <system-test> write-system-test)
  227. (define-gexp-compiler (compile-system-test (test <system-test>)
  228. system target)
  229. "Compile TEST to a derivation."
  230. ;; XXX: SYSTEM and TARGET are ignored.
  231. (system-test-value test))
  232. (define (test-modules)
  233. "Return the list of modules that define system tests."
  234. (scheme-modules (dirname (search-path %load-path "guix.scm"))
  235. "gnu/tests"
  236. #:warn warn-about-load-error))
  237. (define (fold-system-tests proc seed)
  238. "Invoke PROC on each system test, passing it the test and the previous
  239. result."
  240. (fold-module-public-variables (lambda (obj result)
  241. (if (system-test? obj)
  242. (cons obj result)
  243. result))
  244. '()
  245. (test-modules)))
  246. (define (all-system-tests)
  247. "Return the list of system tests."
  248. (reverse (fold-system-tests cons '())))
  249. ;;; tests.scm ends here