Store information about system tests

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