all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
blob b0cb3bd2bf7574425948940c87078192c78db334 4923 bytes (raw)
name: build-aux/run-system-tests.scm 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
 
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 (run-system-tests)
  #:use-module (gnu tests)
  #:use-module (gnu packages package-management)
  #:use-module ((gnu ci) #:select (channel-instance->package))
  #:use-module (guix store)
  #:use-module ((guix status) #:select (with-status-verbosity))
  #:use-module (guix monads)
  #:use-module (guix channels)
  #:use-module (guix derivations)
  #:use-module ((guix git-download) #:select (git-predicate))
  #:use-module (guix utils)
  #:use-module (guix ui)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (ice-9 match)
  #:export (run-system-tests))

(define (built-derivations* drv)
  (lambda (store)
    (guard (c ((store-protocol-error? c)
               (values #f store)))
      (values (build-derivations store drv) store))))

(define (filterm mproc lst)                       ;XXX: move to (guix monads)
  (with-monad %store-monad
    (>>= (foldm %store-monad
                (lambda (item result)
                  (mlet %store-monad ((keep? (mproc item)))
                    (return (if keep?
                                (cons item result)
                                result))))
                '()
                lst)
         (lift1 reverse %store-monad))))

(define (tests-for-channel-instance instance)
  "Return a list of tests for perform, using Guix from INSTANCE, a channel
instance."
  ;; Honor the 'TESTS' environment variable so that one can select a subset
  ;; of tests to run in the usual way:
  ;;
  ;;   make check-system TESTS=installed-os
  (parameterize ((current-guix-package
                  (channel-instance->package instance)))
    (match (getenv "TESTS")
      (#f
       (all-system-tests))
      ((= string-tokenize (tests ...))
       (filter (lambda (test)
                 (member (system-test-name test) tests))
               (all-system-tests))))))



(define (run-system-tests . args)
  (define source
    (string-append (current-source-directory) "/.."))

  (with-store store
    (with-status-verbosity 2
      (run-with-store store
        ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees
        ;; "fresh" file names and thus doesn't find itself loading .go files
        ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'.
        ;; XXX: It would be best to not do it upfront because we may need it.
        (mlet* %store-monad ((source (interned-file source "guix-source"
                                                    #:recursive? #t
                                                    #:select?
                                                    (or (git-predicate source)
                                                        (const #t))))
                             (instance -> (checkout->channel-instance source))
                             (tests -> (tests-for-channel-instance instance))
                             (drv (mapm %store-monad system-test-value tests))
                             (out -> (map derivation->output-path drv)))
          (format (current-error-port) "Running ~a system tests...~%"
                  (length tests))

          (mbegin %store-monad
            (show-what-to-build* drv)
            (set-build-options* #:keep-going? #t #:keep-failed? #t
                                #:print-build-trace #t
                                #:print-extended-build-trace? #t
                                #:fallback? #t)
            (built-derivations* drv)
            (mlet %store-monad ((valid  (filterm (store-lift valid-path?)
                                                 out))
                                (failed (filterm (store-lift
                                                  (negate valid-path?))
                                                 out)))
              (format #t "TOTAL: ~a\n" (length drv))
              (for-each (lambda (item)
                          (format #t "PASS: ~a~%" item))
                        valid)
              (for-each (lambda (item)
                          (format #t "FAIL: ~a~%" item))
                        failed)
              (exit (null? failed)))))))))

debug log:

solving b0cb3bd2bf ...
found b0cb3bd2bf in https://git.savannah.gnu.org/cgit/guix.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.