[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Thu, 8 Apr 2021 09:42:55 -0400 (EDT) |
branch: master
commit d86c4edee7e390b6902cf4f5970b2f1be4edeca6
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Thu Apr 8 15:37:43 2021 +0200
Add specification period support.
* src/sql/upgrade-4.sql: New file.
* Makefile.am (dist_sql_DATA): Add it.
* src/schema.sql (Specifications)[period]: New field.
* src/cuirass/base.scm (process-specs): Honor the specification period.
* src/cuirass/database.scm (db-get-time-since-previous-build): Rename it
into ...
(db-get-time-since-previous-eval): ... this new procedure.
* src/cuirass/specification.scm (<specification>)[period]: New field.
(specification->sexp, sexp->specification): Adapt accordingly.
* src/cuirass/templates.scm (specification-edit): Ditto.
* tests/database.scm ("db-get-time-since-previous-build"): Remame it into
...
("db-get-time-since-previous-eval"): ... this new procedure.
---
Makefile.am | 3 ++-
doc/cuirass.texi | 9 +++++++++
src/cuirass/base.scm | 14 +++++++++++++-
src/cuirass/database.scm | 38 +++++++++++++++-----------------------
src/cuirass/http.scm | 4 ++++
src/cuirass/specification.scm | 6 ++++++
src/cuirass/templates.scm | 13 +++++++++++++
src/schema.sql | 1 +
src/sql/upgrade-4.sql | 5 +++++
tests/database.scm | 4 ++--
10 files changed, 70 insertions(+), 27 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 9a599a2..dfab623 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -90,7 +90,8 @@ dist_pkgdata_DATA = src/schema.sql
dist_sql_DATA = \
src/sql/upgrade-1.sql \
src/sql/upgrade-2.sql \
- src/sql/upgrade-3.sql
+ src/sql/upgrade-3.sql \
+ src/sql/upgrade-4.sql
dist_css_DATA = \
src/static/css/choices.min.css \
diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index 72c07ff..8ba697f 100644
--- a/doc/cuirass.texi
+++ b/doc/cuirass.texi
@@ -208,6 +208,12 @@ will send build notifications emails from
@code{build@@cuirass.org} to
The different notification types are described in the
@ref{Notifications} section.
+@item @code{period} (default: @code{0})
+When @code{period} is strictly superior to zero new evaluations will
+only be triggered if the latest evaluation occured more than
+@code{period} seconds ago. Otherwise, the specification will be
+evaluated for each new commit in the declared @code{channels}.
+
@item @code{priority} (default: @code{9})
The specification priority relatively to the other specifications, as
an integer ranging from 0 to 9 where 0 is the higher priority and 9
@@ -1004,6 +1010,9 @@ The build outputs to be saved by Cuirass as an SEXP
string.
@item notifications
The build notifications to be sent by Cuirass as an SEXP string.
+@item period
+The specification periodicity as an integer.
+
@item priority
The specification priority relatively to the other specifications, as
an integer ranging from 0 to 9 where 0 is the higher priority and 9
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 44f3711..1b0dec6 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -674,6 +674,17 @@ by BUILD-OUTPUTS."
(define (process-specs jobspecs)
"Evaluate and build JOBSPECS and store results in the database."
+ (define (new-eval? spec)
+ (let ((name (specification-name spec))
+ (period (specification-period spec)))
+ (or (= period 0)
+ (let ((time
+ (db-get-time-since-previous-eval name)))
+ (cond
+ ((not time) #t)
+ ((> time period) #t)
+ (else #f))))))
+
(define (process spec)
(with-store store
(let* ((name (specification-name spec))
@@ -709,7 +720,8 @@ by BUILD-OUTPUTS."
;; Catch Git errors, which might be transient, and keep going.
(catch 'git-error
(lambda ()
- (process spec))
+ (and (new-eval? spec)
+ (process spec)))
(lambda (key error)
(log-message "Git error while fetching inputs of '~a': ~s~%"
(specification-name spec)
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 7c83723..6f64701 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -67,7 +67,7 @@
db-add-build-product
db-get-output
db-get-outputs
- db-get-time-since-previous-build
+ db-get-time-since-previous-eval
db-get-build-percentages
db-get-jobs
db-register-builds
@@ -410,13 +410,14 @@ RETURNING (specification, revision);"))
(match (expect-one-row
(exec-query/bind db "\
INSERT INTO Specifications (name, build, channels, \
-build_outputs, notifications, priority, systems) \
+build_outputs, notifications, period, priority, systems) \
VALUES ("
(specification-name spec) ", "
(specification-build spec) ", "
channels ", "
build-outputs ", "
notifications ", "
+ (specification-period spec) ", "
(specification-priority spec) ", "
(specification-systems spec) ")
ON CONFLICT(name) DO UPDATE
@@ -424,6 +425,7 @@ SET build = " (specification-build spec) ",
channels = " channels ",
build_outputs = " build-outputs ",
notifications = " notifications ",
+period = " (specification-period spec) ",
priority = " (specification-priority spec) ",
systems = " (specification-systems spec)
"RETURNING name;"))
@@ -446,14 +448,15 @@ DELETE FROM Specifications WHERE name=" name ";")))
((rows (if name
(exec-query/bind db "
SELECT name, build, channels, build_outputs, notifications,\
-priority, systems FROM Specifications WHERE name =" name ";")
+period, priority, systems FROM Specifications WHERE name =" name ";")
(exec-query db "
SELECT name, build, channels, build_outputs, notifications,\
-priority, systems FROM Specifications ORDER BY name ASC;")))
+period, priority, systems FROM Specifications ORDER BY name ASC;")))
(specs '()))
(match rows
(() (reverse specs))
- (((name build channels build-outputs notifications priority systems)
+ (((name build channels build-outputs notifications
+ period priority systems)
. rest)
(loop rest
(cons (specification
@@ -468,6 +471,7 @@ priority, systems FROM Specifications ORDER BY name ASC;")))
(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)))))))
@@ -673,16 +677,14 @@ WHERE derivation =" derivation ";"))
(cons `(,name . ((#:path . ,path)))
outputs)))))))
-(define (db-get-time-since-previous-build job-name specification)
- "Return the time difference in seconds between the current time and the
-registration time of the last build for JOB-NAME and SPECIFICATION."
+(define (db-get-time-since-previous-eval specification)
+ "Return the time elapsed since the last evaluation of SPECIFICATION."
(with-db-worker-thread db
(match (expect-one-row
(exec-query/bind db "
-SELECT extract(epoch from now())::int - Builds.timestamp FROM Builds
-INNER JOIN Evaluations on Builds.evaluation = Evaluations.id
-WHERE job_name = " job-name "AND specification = " specification
-"ORDER BY Builds.timestamp DESC LIMIT 1"))
+SELECT extract(epoch from now())::int - Evaluations.timestamp FROM Evaluations
+WHERE specification = " specification
+"ORDER BY Evaluations.timestamp DESC LIMIT 1"))
((time)
(string->number time))
(else #f))))
@@ -786,7 +788,6 @@ ORDER BY Jobs.name")
(system (assq-ref job #:system))
(nix-name (assq-ref job #:nix-name))
(log (assq-ref job #:log))
- (period (assq-ref job #:period))
(priority (or (assq-ref job #:priority) max-priority))
(max-silent (assq-ref job #:max-silent-time))
(timeout (assq-ref job #:timeout))
@@ -811,16 +812,7 @@ ORDER BY Jobs.name")
(#:timestamp . ,cur-time)
(#:starttime . 0)
(#:stoptime . 0))))
- (if period
- (let* ((spec (specification-name specification))
- (time
- (db-get-time-since-previous-build job-name spec))
- (add-build? (cond
- ((not time) #t)
- ((> time period) #t)
- (else #f))))
- (and add-build? (db-add-build build)))
- (db-add-build build))))
+ (db-add-build build)))
;; Always register JOB inside the Jobs table. If there are new outputs,
;; JOB will refer to the newly created build. Otherwise, it will refer
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 2c80de9..b1eff84 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -168,6 +168,7 @@
(#:notifications . ,(list->vector
(map notification->json-object
(specification-notifications spec))))
+ (#:period . ,(specification-period spec))
(#:priority . ,(specification-priority spec))
(#:systems . ,(list->vector
(specification-systems spec)))))
@@ -391,6 +392,8 @@ into a specification record and return it."
(filter-field 'channel-name)
(filter-field 'channel-url)
(filter-field 'channel-branch)))
+ (period (string->number
+ (assq-ref params 'period)))
(priority (string->number
(assq-ref params 'priority)))
(systems (fold
@@ -406,6 +409,7 @@ into a specification record and return it."
(cons build build-params)
build))
(channels channels)
+ (period period)
(priority priority)
(systems systems))))
diff --git a/src/cuirass/specification.scm b/src/cuirass/specification.scm
index 158d53f..e532120 100644
--- a/src/cuirass/specification.scm
+++ b/src/cuirass/specification.scm
@@ -45,6 +45,7 @@
specification-name
specification-build
specification-channels
+ specification-period
specification-priority
specification-build-outputs
specification-notifications
@@ -153,6 +154,8 @@
(default '()))
(notifications specification-notifications
(default '()))
+ (period specification-period
+ (default 0)) ;integer
(priority specification-priority ;integer
(default 9))
(systems specification-systems ;list of strings
@@ -165,6 +168,7 @@
(channels ,(specification-channels spec))
(build-outputs ,(specification-build-outputs spec))
(notifications ,(specification-notifications spec))
+ (period ,(specification-period spec))
(priority ,(specification-priority spec))
(systems ,(specification-systems spec))))
@@ -176,6 +180,7 @@
('channels channels)
('build-outputs build-outputs)
('notifications notifications)
+ ('period period)
('priority priority)
('systems systems))
(specification (name name)
@@ -183,6 +188,7 @@
(channels channels)
(build-outputs build-outputs)
(notifications notifications)
+ (period period)
(priority priority)
(systems systems)))))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 213e580..b96e874 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -446,6 +446,7 @@ the existing SPEC otherwise."
((? symbol? build) build)
((build _ ...) build))))
(channels (and spec (specification-channels spec)))
+ (period (and spec (specification-period spec)))
(priority (and spec (specification-priority spec)))
(systems (and spec (specification-systems spec))))
`(span
@@ -612,6 +613,18 @@ if ($('.param-select-row').is(':visible')) {
,@(channels->html
(if spec channels (list %default-guix-channel)))
(div (@ (class "form-group row"))
+ (label (@ (for "period")
+ (class "col-sm-2 col-form-label"))
+ "Period")
+ (div (@ (class "col-sm-4"))
+ (input
+ (@ (type "number")
+ (class "form-control")
+ (id "period")
+ (name "period")
+ (min 0)
+ (value ,(or period 0))))))
+ (div (@ (class "form-group row"))
(label (@ (for "priority")
(class "col-sm-2 col-form-label"))
"Priority")
diff --git a/src/schema.sql b/src/schema.sql
index 1c050d8..5158732 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -10,6 +10,7 @@ CREATE TABLE Specifications (
channels TEXT NOT NULL,
build_outputs TEXT NOT NULL,
notifications TEXT NOT NULL,
+ period INTEGER NOT NULL DEFAULT 0,
priority INTEGER NOT NULL DEFAULT 0,
systems TEXT NOT NULL
);
diff --git a/src/sql/upgrade-4.sql b/src/sql/upgrade-4.sql
new file mode 100644
index 0000000..e4f45b9
--- /dev/null
+++ b/src/sql/upgrade-4.sql
@@ -0,0 +1,5 @@
+BEGIN TRANSACTION;
+
+ALTER TABLE Specifications ADD COLUMN period INTEGER NOT NULL DEFAULT 0;
+
+COMMIT;
diff --git a/tests/database.scm b/tests/database.scm
index a86f0b0..a436e86 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -186,8 +186,8 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0,
0);")
'(("foo" (#:path . "/foo.drv.output")))
(db-get-outputs "/foo.drv"))
- (test-assert "db-get-time-since-previous-build"
- (db-get-time-since-previous-build "job" "guix"))
+ (test-assert "db-get-time-since-previous-eval"
+ (db-get-time-since-previous-eval "guix"))
(test-assert "db-register-builds"
(let ((drv "/test.drv"))