branch master updated: Add specifications deactivation support.

[Mathieu Othacehe]

This is an automated email from the git hooks/post-receive script.

mothacehe pushed a commit to branch master
in repository guix-cuirass.

The following commit(s) were added to refs/heads/master by this push:
     new b362f06  Add specifications deactivation support.
b362f06 is described below

commit b362f06b9134f99a476e0f2ec32335ce6ddc6e8c
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Mon Nov 29 11:10:00 2021 +0100

    Add specifications deactivation support.
    
    Add support to deactivate specifications. This allows to keep specifications
    and the associated builds around but without evaluating them.
    
    Fixes: <https://issues.guix.gnu.org/51837> and
    <https://issues.guix.gnu.org/52110>.
    
    * src/sql/upgrade-15.sql: New file.
    * Makefile.am (dist_sql_DATA): Add it.
    * src/schema.sql (Specification)[is_active]: New field.
    * src/cuirass/database.scm (db-deactivate-specification): New procedure.
    (db-add-or-update-specification, db-get-specifications): Adapt them.
    * src/cuirass/http.scm (url-handler): New
    /admin/specifications/deactivate/spec route.
    * src/cuirass/specification.scm (<specification>)[is-active?]: New field.
    (specification->sexp, sexp->specification): Adapt them.
    * src/cuirass/templates.scm (specifications-table): Replace "Delete" by
    "Deactivate".
    * tests/database.scm (db-add-or-update-specification 3): New test.
---
 Makefile.am                   |  3 +-
 src/cuirass/database.scm      | 67 ++++++++++++++++++++++++++++---------------
 src/cuirass/http.scm          |  7 +++++
 src/cuirass/specification.scm | 14 ++++++---
 src/cuirass/templates.scm     |  4 +--
 src/schema.sql                |  3 +-
 src/sql/upgrade-15.sql        |  5 ++++
 tests/database.scm            | 10 +++++++
 8 files changed, 82 insertions(+), 31 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 9a1518d..cf9f408 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -102,7 +102,8 @@ dist_sql_DATA =                             \
   src/sql/upgrade-11.sql                       \
   src/sql/upgrade-12.sql                       \
   src/sql/upgrade-13.sql                       \
-  src/sql/upgrade-14.sql
+  src/sql/upgrade-14.sql                       \
+  src/sql/upgrade-15.sql
 
 dist_css_DATA =                                        \
   src/static/css/choices.min.css               \
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 89417b0..d47b709 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -53,6 +53,7 @@
             read-sql-file
             db-add-checkout
             db-add-or-update-specification
+            db-deactivate-specification
             db-remove-specification
             db-get-specification
             db-get-specifications
@@ -413,11 +414,13 @@ RETURNING (specification, revision);"))
           (build-outputs (map build-output->sexp
                               (specification-build-outputs spec)))
           (notifications (map notification->sexp
-                              (specification-notifications spec))))
+                              (specification-notifications spec)))
+          (bool->int (lambda (bool)
+                       (if bool 1 0))))
       (match (expect-one-row
               (exec-query/bind db "\
 INSERT INTO Specifications (name, build, channels, \
-build_outputs, notifications, period, priority, systems) \
+build_outputs, notifications, period, priority, systems, is_active) \
   VALUES ("
                                (specification-name spec) ", "
                                (specification-build spec) ", "
@@ -426,7 +429,9 @@ build_outputs, notifications, period, priority, systems) \
                                notifications ", "
                                (specification-period spec) ", "
                                (specification-priority spec) ", "
-                               (specification-systems spec) ")
+                               (specification-systems spec) ", "
+                               (bool->int
+                                (specification-is-active? spec)) ")
 ON CONFLICT(name) DO UPDATE
 SET build = " (specification-build spec) ",
 channels = " channels ",
@@ -439,6 +444,12 @@ systems = " (specification-systems spec)
         ((name) name)
         (else #f)))))
 
+(define (db-deactivate-specification name)
+  "Deactivate the specification matching NAME from the database."
+  (with-db-worker-thread db
+    (exec-query/bind db "\
+UPDATE Specifications SET is_active = 0 WHERE name=" name ";")))
+
 (define (db-remove-specification name)
   "Remove the specification matching NAME from the database."
   (with-db-worker-thread db
@@ -449,39 +460,49 @@ DELETE FROM Specifications WHERE name=" name ";")))
   "Retrieve a specification in the database with the given NAME."
   (expect-one-row (db-get-specifications name)))
 
-(define* (db-get-specifications #:optional name)
+(define* (db-get-specifications #:optional name
+                                #:key (filter-inactive? #t))
   (with-db-worker-thread db
     (let loop
         ((rows  (if name
                     (exec-query/bind db "
 SELECT name, build, channels, build_outputs, notifications,\
-period, priority, systems FROM Specifications WHERE name =" name ";")
+period, priority, systems, is_active \
+FROM Specifications WHERE name =" name ";")
                     (exec-query db "
 SELECT name, build, channels, build_outputs, notifications,\
-period, priority, systems FROM Specifications ORDER BY name ASC;")))
+period, priority, systems, is_active \
+FROM Specifications ORDER BY name ASC;")))
          (specs '()))
       (match rows
         (() (reverse specs))
         (((name build channels build-outputs notifications
-                period priority systems)
+                period priority systems is-active?)
           . rest)
          (loop rest
-               (cons (specification
-                      (name name)
-                      (build (with-input-from-string build read))
-                      (channels
-                       (map sexp->channel*
-                            (with-input-from-string channels read)))
-                      (build-outputs
-                       (map sexp->build-output
-                            (with-input-from-string build-outputs read)))
-                      (notifications
-                       (map sexp->notification
-                            (with-input-from-string notifications read)))
-                      (period (string->number period))
-                      (priority (string->number priority))
-                      (systems (with-input-from-string systems read)))
-                     specs)))))))
+               (let ((is-active?
+                      (eq? (with-input-from-string is-active? read) 1)))
+                 (if (and filter-inactive?
+                          (not is-active?))
+                     specs
+                     (cons
+                      (specification
+                       (name name)
+                       (build (with-input-from-string build read))
+                       (channels
+                        (map sexp->channel*
+                             (with-input-from-string channels read)))
+                       (build-outputs
+                        (map sexp->build-output
+                             (with-input-from-string build-outputs read)))
+                       (notifications
+                        (map sexp->notification
+                             (with-input-from-string notifications read)))
+                       (period (string->number period))
+                       (priority (string->number priority))
+                       (systems (with-input-from-string systems read))
+                       (is-active? is-active?))
+                      specs)))))))))
 
 (define-enumeration evaluation-status
   (started          -1)
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 14d1249..c8c6994 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -644,6 +644,13 @@ passed, only display JOBS targeting this SYSTEM."
                         `((location . ,(string->uri-reference "/"))))
         #:body "")))
 
+    (('GET "admin" "specifications" "deactivate" name)
+     (db-deactivate-specification name)
+     (respond
+      (build-response #:code 302
+                      #:headers
+                      `((location . ,(string->uri-reference "/"))))
+      #:body ""))
     (('GET "admin" "specifications" "delete" name)
      (db-remove-specification name)
      (respond
diff --git a/src/cuirass/specification.scm b/src/cuirass/specification.scm
index 89a9c80..b9a016f 100644
--- a/src/cuirass/specification.scm
+++ b/src/cuirass/specification.scm
@@ -50,6 +50,7 @@
             specification-build-outputs
             specification-notifications
             specification-systems
+            specification-is-active?
 
             specification->sexp
             sexp->specification
@@ -169,7 +170,9 @@
   (priority           specification-priority ;integer
                       (default 9))
   (systems            specification-systems ;list of strings
-                      (default (list (%current-system)))))
+                      (default (list (%current-system))))
+  (is-active?         specification-is-active? ;boolean
+                      (default #t)))
 
 (define (specification->sexp spec)
   "Return an sexp describing SPEC."
@@ -180,7 +183,8 @@
                   (notifications ,(specification-notifications spec))
                   (period ,(specification-period spec))
                   (priority ,(specification-priority spec))
-                  (systems ,(specification-systems spec))))
+                  (systems ,(specification-systems spec))
+                  (is-active? ,(specification-is-active? spec))))
 
 (define (sexp->specification sexp)
   "Return the specification corresponding to SEXP."
@@ -192,7 +196,8 @@
                      ('notifications notifications)
                      ('period period)
                      ('priority priority)
-                     ('systems systems))
+                     ('systems systems)
+                     ('is-active? is-active?))
      (specification (name name)
                     (build build)
                     (channels channels)
@@ -200,7 +205,8 @@
                     (notifications notifications)
                     (period period)
                     (priority priority)
-                    (systems systems)))))
+                    (systems systems)
+                    (is-active? is-active?)))))
 
 (define (read-specifications file)
   (let ((modules (make-user-module '((guix channels)
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 343b693..a272bce 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -432,9 +432,9 @@ system whose names start with " (code "guile-") ":" (br)
                                       " Edit"))
                                (li (@ (role "menuitem"))
                                    (a (@ (class "dropdown-item")
-                                         (href "/admin/specifications/delete/"
+                                         (href 
"/admin/specifications/deactivate/"
                                                ,(specification-name spec)))
-                                      " Delete"))))))))
+                                      " Deactivate"))))))))
                  specs)))))))
 
 (define* (specification-edit #:optional spec)
diff --git a/src/schema.sql b/src/schema.sql
index 70fa90a..4b52daa 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -12,7 +12,8 @@ CREATE TABLE Specifications (
   notifications TEXT NOT NULL,
   period        INTEGER NOT NULL DEFAULT 0,
   priority      INTEGER NOT NULL DEFAULT 0,
-  systems       TEXT NOT NULL
+  systems       TEXT NOT NULL,
+  is_active     INTEGER NOT NULL DEFAULT 1
 );
 
 CREATE TABLE Evaluations (
diff --git a/src/sql/upgrade-15.sql b/src/sql/upgrade-15.sql
new file mode 100644
index 0000000..59804be
--- /dev/null
+++ b/src/sql/upgrade-15.sql
@@ -0,0 +1,5 @@
+BEGIN TRANSACTION;
+
+ALTER TABLE Specifications ADD COLUMN is_active INTEGER NOT NULL DEFAULT 1;
+
+COMMIT;
diff --git a/tests/database.scm b/tests/database.scm
index 06c8e63..7458070 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -123,6 +123,16 @@
       (specification-build
        (db-get-specification "guix"))))
 
+  (test-assert "db-add-or-update-specification 3"
+    (begin
+      (db-add-or-update-specification
+       (specification
+        (inherit example-spec)
+        (name "tmp")
+        (build 'core)))
+      (db-deactivate-specification "tmp")
+      (not (db-get-specification "tmp"))))
+
   (test-assert "exec-query"
     (begin
       (exec-query (%db) "\