Mirror of GNU Guix
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.

183 lines
6.3 KiB

build: Add a Guile custom test driver using SRFI-64. Before that '.log' files for scheme tests were fragmented and not included in test-suite.log. This unifies the semantics of SRFI-64 API with Automake test suite. * build-aux/test-driver.scm: New file. * Makefile.am (SCM_LOG_DRIVER, AM_SCM_LOG_DRIVER_FLAGS): New variables. (SCM_LOG_COMPILER, AM_SCM_LOG_FLAGS): Delete variables. (AM_TESTS_ENVIRONMENT): Set GUILE_AUTO_COMPILE to 0. * test-env.in: Silence guix-daemon. * doc/guix.texi (Running the Test Suite): Describe how to display the detailed results. Bug reports require only 'test-suite.log' file. * tests/base32.scm, tests/build-utils.scm, tests/builders.scm, tests/challenge.scm, tests/cpan.scm, tests/cpio.scm, tests/cran.scm, tests/cve.scm, tests/derivations.scm, tests/elpa.scm, tests/file-systems.scm, tests/gem.scm, tests/gexp.scm, tests/gnu-maintenance.scm, tests/grafts.scm, tests/graph.scm, tests/gremlin.scm, tests/hackage.scm, tests/hash.scm, tests/import-utils.scm, tests/lint.scm, tests/monads.scm, tests/nar.scm, tests/packages.scm, tests/pk-crypto.scm, tests/pki.scm, tests/profiles.scm, tests/publish.scm, tests/pypi.scm, tests/records.scm, tests/scripts-build.scm, tests/scripts.scm, tests/services.scm, tests/sets.scm, tests/size.scm, tests/snix.scm, tests/store.scm, tests/substitute.scm, tests/syscalls.scm, tests/system.scm, tests/ui.scm, tests/union.scm, tests/upstream.scm, tests/utils.scm: Don't exit at the end of test groups. * tests/containers.scm: Likewise. Use 'test-skip' instead of exiting with error code 77.
7 years ago
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2015 David Thompson <davet@gnu.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. (define-module (test-containers)
  19. #:use-module (guix utils)
  20. #:use-module (guix build syscalls)
  21. #:use-module (gnu build linux-container)
  22. #:use-module (gnu system file-systems)
  23. #:use-module (srfi srfi-64)
  24. #:use-module (ice-9 match))
  25. (define (assert-exit x)
  26. (primitive-exit (if x 0 1)))
  27. (test-begin "containers")
  28. ;; Skip these tests unless user namespaces are available and the setgroups
  29. ;; file (introduced in Linux 3.19 to address a security issue) exists.
  30. (define (skip-if-unsupported)
  31. (unless (and (user-namespace-supported?)
  32. (unprivileged-user-namespace-supported?)
  33. (setgroups-supported?))
  34. (test-skip 1)))
  35. (skip-if-unsupported)
  36. (test-assert "call-with-container, exit with 0 when there is no error"
  37. (zero?
  38. (call-with-container '() (const #t) #:namespaces '(user))))
  39. (skip-if-unsupported)
  40. (test-assert "call-with-container, user namespace"
  41. (zero?
  42. (call-with-container '()
  43. (lambda ()
  44. ;; The user is root within the new user namespace.
  45. (assert-exit (and (zero? (getuid)) (zero? (getgid)))))
  46. #:namespaces '(user))))
  47. (skip-if-unsupported)
  48. (test-assert "call-with-container, uts namespace"
  49. (zero?
  50. (call-with-container '()
  51. (lambda ()
  52. ;; The user is root within the container and should be able to change
  53. ;; the hostname of that container.
  54. (sethostname "test-container")
  55. (primitive-exit 0))
  56. #:namespaces '(user uts))))
  57. (skip-if-unsupported)
  58. (test-assert "call-with-container, pid namespace"
  59. (zero?
  60. (call-with-container '()
  61. (lambda ()
  62. (match (primitive-fork)
  63. (0
  64. ;; The first forked process in the new pid namespace is pid 2.
  65. (assert-exit (= 2 (getpid))))
  66. (pid
  67. (primitive-exit
  68. (match (waitpid pid)
  69. ((_ . status)
  70. (status:exit-val status)))))))
  71. #:namespaces '(user pid))))
  72. (skip-if-unsupported)
  73. (test-assert "call-with-container, mnt namespace"
  74. (zero?
  75. (call-with-container (list (file-system
  76. (device "none")
  77. (mount-point "/testing")
  78. (type "tmpfs")
  79. (check? #f)))
  80. (lambda ()
  81. (assert-exit (file-exists? "/testing")))
  82. #:namespaces '(user mnt))))
  83. (skip-if-unsupported)
  84. (test-equal "call-with-container, mnt namespace, wrong bind mount"
  85. `(system-error ,ENOENT)
  86. ;; An exception should be raised; see <http://bugs.gnu.org/23306>.
  87. (catch 'system-error
  88. (lambda ()
  89. (call-with-container (list (file-system
  90. (device "/does-not-exist")
  91. (mount-point "/foo")
  92. (type "none")
  93. (flags '(bind-mount))
  94. (check? #f)))
  95. (const #t)
  96. #:namespaces '(user mnt)))
  97. (lambda args
  98. (list 'system-error (system-error-errno args)))))
  99. (skip-if-unsupported)
  100. (test-assert "call-with-container, all namespaces"
  101. (zero?
  102. (call-with-container '()
  103. (lambda ()
  104. (primitive-exit 0)))))
  105. (skip-if-unsupported)
  106. (test-assert "container-excursion"
  107. (call-with-temporary-directory
  108. (lambda (root)
  109. ;; Two pipes: One for the container to signal that the test can begin,
  110. ;; and one for the parent to signal to the container that the test is
  111. ;; over.
  112. (match (list (pipe) (pipe))
  113. (((start-in . start-out) (end-in . end-out))
  114. (define (container)
  115. (close end-out)
  116. (close start-in)
  117. ;; Signal for the test to start.
  118. (write 'ready start-out)
  119. (close start-out)
  120. ;; Wait for test completion.
  121. (read end-in)
  122. (close end-in))
  123. (define (namespaces pid)
  124. (let ((pid (number->string pid)))
  125. (map (lambda (ns)
  126. (readlink (string-append "/proc/" pid "/ns/" ns)))
  127. '("user" "ipc" "uts" "net" "pid" "mnt"))))
  128. (let* ((pid (run-container root '() %namespaces 1 container))
  129. (container-namespaces (namespaces pid))
  130. (result
  131. (begin
  132. (close start-out)
  133. ;; Wait for container to be ready.
  134. (read start-in)
  135. (close start-in)
  136. (container-excursion pid
  137. (lambda ()
  138. ;; Fork again so that the pid is within the context of
  139. ;; the joined pid namespace instead of the original pid
  140. ;; namespace.
  141. (match (primitive-fork)
  142. (0
  143. ;; Check that all of the namespace identifiers are
  144. ;; the same as the container process.
  145. (assert-exit
  146. (equal? container-namespaces
  147. (namespaces (getpid)))))
  148. (fork-pid
  149. (match (waitpid fork-pid)
  150. ((_ . status)
  151. (primitive-exit
  152. (status:exit-val status)))))))))))
  153. (close end-in)
  154. ;; Stop the container.
  155. (write 'done end-out)
  156. (close end-out)
  157. (waitpid pid)
  158. (zero? result)))))))
  159. (skip-if-unsupported)
  160. (test-equal "container-excursion, same namespaces"
  161. 42
  162. ;; The parent and child are in the same namespaces. 'container-excursion'
  163. ;; should notice that and avoid calling 'setns' since that would fail.
  164. (container-excursion (getpid)
  165. (lambda ()
  166. (primitive-exit 42))))
  167. (test-end)