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.

98 lines
3.7 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@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. (use-modules (gnu tests)
  19. (gnu packages package-management)
  20. ((gnu ci) #:select (channel-source->package))
  21. ((guix git-download) #:select (git-predicate))
  22. ((guix utils) #:select (current-source-directory))
  23. (git)
  24. (ice-9 match))
  25. (define (source-commit directory)
  26. "Return the commit of the head of DIRECTORY or #f if it could not be
  27. determined."
  28. (let ((repository #f))
  29. (catch 'git-error
  30. (lambda ()
  31. (set! repository (repository-open directory))
  32. (let* ((head (repository-head repository))
  33. (target (reference-target head))
  34. (commit (oid->string target)))
  35. (repository-close! repository)
  36. commit))
  37. (lambda _
  38. (when repository
  39. (repository-close! repository))
  40. #f))))
  41. (define (tests-for-current-guix source commit)
  42. "Return a list of tests for perform, using Guix built from SOURCE, a channel
  43. instance."
  44. ;; Honor the 'TESTS' environment variable so that one can select a subset
  45. ;; of tests to run in the usual way:
  46. ;;
  47. ;; make check-system TESTS=installed-os
  48. (parameterize ((current-guix-package
  49. (channel-source->package source #:commit commit)))
  50. (match (getenv "TESTS")
  51. (#f
  52. (all-system-tests))
  53. ((= string-tokenize (tests ...))
  54. (filter (lambda (test)
  55. (member (system-test-name test) tests))
  56. (all-system-tests))))))
  57. (define (system-test->manifest-entry test)
  58. "Return a manifest entry for TEST, a system test."
  59. (manifest-entry
  60. (name (string-append "test." (system-test-name test)))
  61. (version "0")
  62. (item test)))
  63. (define (system-test-manifest)
  64. "Return a manifest containing all the system tests, or all those selected by
  65. the 'TESTS' environment variable."
  66. (define source
  67. (string-append (current-source-directory) "/.."))
  68. (define commit
  69. ;; Fetch the current commit ID so we can potentially build the same
  70. ;; derivation as ci.guix.gnu.org.
  71. (source-commit source))
  72. ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees
  73. ;; "fresh" file names and thus doesn't find itself loading .go files
  74. ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'.
  75. (let* ((source (local-file source
  76. (if commit
  77. (string-append "guix-"
  78. (string-take commit 7))
  79. "guix-source")
  80. #:recursive? #t
  81. #:select?
  82. (or (git-predicate source)
  83. (const #t))))
  84. (tests (tests-for-current-guix source commit)))
  85. (format (current-error-port) "Selected ~a system tests...~%"
  86. (length tests))
  87. (manifest (map system-test->manifest-entry tests))))
  88. ;; Return the manifest.
  89. (system-test-manifest)