aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am1
-rw-r--r--guix-data-service/jobs/load-new-guix-revision.scm47
-rw-r--r--guix-data-service/model/system-test.scm65
-rw-r--r--sqitch/sqitch.plan1
4 files changed, 111 insertions, 3 deletions
diff --git a/Makefile.am b/Makefile.am
index ba541ce..5f1ed30 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -93,6 +93,7 @@ SOURCES = \
guix-data-service/model/package-derivation.scm \
guix-data-service/model/package-metadata.scm \
guix-data-service/model/package.scm \
+ guix-data-service/model/system-test.scm \
guix-data-service/model/utils.scm \
guix-data-service/web/build-server/controller.scm \
guix-data-service/web/build-server/html.scm \
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index 1e73430..cc927d8 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -49,6 +49,7 @@
#:use-module (guix-data-service model location)
#:use-module (guix-data-service model package-metadata)
#:use-module (guix-data-service model derivation)
+ #:use-module (guix-data-service model system-test)
#:export (log-for-job
count-log-parts
combine-log-parts!
@@ -236,6 +237,36 @@ WHERE job_id = $1"
lock time-taken))
(f)))))
+(define (all-inferior-system-tests inf store)
+ (define extract
+ '(lambda (store)
+ (map
+ (lambda (system-test)
+ (list (system-test-name system-test)
+ (system-test-description system-test)
+ (derivation-file-name
+ (run-with-store store
+ (mbegin %store-monad
+ (system-test-value system-test))))
+ (match (system-test-location system-test)
+ (($ <location> file line column)
+ (list file
+ line
+ column)))))
+ (all-system-tests))))
+
+ (let ((system-test-data
+ (log-time
+ "getting system tests"
+ (lambda ()
+ (inferior-eval-with-store inf store extract)))))
+
+ (for-each (lambda (derivation-file-name)
+ (add-temp-root store derivation-file-name))
+ (map third system-test-data))
+
+ system-test-data))
+
(define (all-inferior-lint-warnings inf store)
(define locales
'("cs_CZ.utf8"
@@ -883,7 +914,8 @@ WHERE job_id = $1"
(inferior-eval '(use-modules (srfi srfi-1)
(srfi srfi-34)
(guix grafts)
- (guix derivations))
+ (guix derivations)
+ (gnu tests))
inf)
(inferior-eval '(when (defined? '%graft?) (%graft? #f)) inf)
@@ -905,7 +937,12 @@ WHERE job_id = $1"
(log-time
"getting inferior derivations"
(lambda ()
- (all-inferior-package-derivations store inf packages)))))
+ (all-inferior-package-derivations store inf packages))))
+ (inferior-system-tests
+ (log-time
+ "getting inferior system tests"
+ (lambda ()
+ (all-inferior-system-tests inf store)))))
(log-time
"acquiring advisory transaction lock: load-new-guix-revision-inserts"
@@ -914,7 +951,6 @@ WHERE job_id = $1"
;; avoid any concurrency issues
(obtain-advisory-transaction-lock conn
'load-new-guix-revision-inserts)))
-
(let* ((package-ids
(insert-packages conn inf packages))
(inferior-package-id->package-database-id
@@ -956,6 +992,11 @@ WHERE job_id = $1"
(insert-guix-revision-lint-warnings conn
guix-revision-id
lint-warning-ids)))
+
+ (insert-system-tests-for-guix-revision conn
+ guix-revision-id
+ inferior-system-tests)
+
(let ((package-derivation-ids
(log-time
"inferior-data->package-derivation-ids"
diff --git a/guix-data-service/model/system-test.scm b/guix-data-service/model/system-test.scm
new file mode 100644
index 0000000..61b16cf
--- /dev/null
+++ b/guix-data-service/model/system-test.scm
@@ -0,0 +1,65 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program 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
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-data-service model system-test)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
+ #:use-module (squee)
+ #:use-module (guix utils)
+ #:use-module (guix-data-service model utils)
+ #:use-module (guix-data-service model location)
+ #:use-module (guix-data-service model derivation)
+ #:export (insert-system-tests-for-guix-revision))
+
+(define (insert-system-tests-for-guix-revision conn
+ guix-revision-id
+ system-test-data)
+ (let ((system-test-ids
+ (insert-missing-data-and-return-all-ids
+ conn
+ "system_tests"
+ '(name description location_id)
+ (map (match-lambda
+ ((name description derivation-file-name location-data)
+ (list name
+ description
+ (location->location-id
+ conn
+ (apply location location-data)))))
+ system-test-data)))
+ (derivation-ids
+ (derivation-file-names->derivation-ids
+ conn
+ (map third system-test-data))))
+
+ (exec-query
+ conn
+ (string-append
+ "
+INSERT INTO guix_revision_system_test_derivations
+ (guix_revision_id, system_test_id, derivation_id)
+VALUES "
+ (string-join
+ (map (lambda (system-test-id derivation-id)
+ (simple-format #f "(~A, ~A, ~A)"
+ guix-revision-id
+ system-test-id
+ derivation-id))
+ system-test-ids
+ derivation-ids)
+ ", "))))
+ #t)
diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan
index 8f960e6..b4e99fd 100644
--- a/sqitch/sqitch.plan
+++ b/sqitch/sqitch.plan
@@ -43,3 +43,4 @@ add_derivation_source_file_nars 2019-12-28T20:37:06Z Christopher Baines <mail@cb
derivation_source_files_store_path_hash_index 2019-12-29T17:53:08Z Christopher Baines <mail@cbaines.net> # Add index on the hash part of the derivation source files store path
build_servers_build_config 2020-01-05T12:06:13Z Christopher Baines <mail@cbaines.net> # Add build_servers_build_config table
git-repositories-x-git-repo-header 2020-01-11T16:39:32Z Christopher Baines <mail@cbaines.net> # Add x_git_repo_header to git_repositories
+system_test_tables 2020-02-02T11:36:20Z Christopher Baines <mail@cbaines.net> # Add tables for storing system tests