cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Store information about system tests

Browse source
This commit is contained in:
Christopher Baines 2020-02-02 20:30:07 +01:00
parent 65850669a0
commit 8f0d5b51b1
4 changed files with 111 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -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 \

47
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -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"

65
guix-data-service/model/system-test.scm Normal file
View file

@ -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)

1
sqitch/sqitch.plan
View file

@ -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