branch: main
commit 331c67ab46b41fd7d19007b23fa9f0b0a06408aa
Author: Ludovic Courtès <l...@gnu.org>
AuthorDate: Tue Jul 16 15:07:43 2024 +0200
http: Removing a jobset terminates its monitor.
Previously, removing a jobset via the HTTP interface would remove it
from the database but it would not terminate its associated monitor.
Consequently, the jobset would still be periodically evaluated, leading
to errors such as:
evaluating 'gitlab-merge-requests-guix-hpc-non-free-ci-doc-19' with token
#6
Uncaught exception in task:
In fibers.scm:
172:8 2 (_)
In cuirass/base.scm:
677:14 1 (_)
In ice-9/boot-9.scm:
1685:16 0 (raise-exception _ #:continuable? _)
ice-9/boot-9.scm:1685:16: In procedure raise-exception:
Throw to key `psql-query-error' with args `(fatal-error
"PGRES_FATAL_ERROR" "ERROR: insert or update on table \"evaluations\" violates
foreign key constraint \"evaluations_specification_fkey\"\nDETAIL: Key
(specification)=(gitlab-merge-requests-guix-hpc-non-free-ci-doc-19) is not
present in table \"specifications\".\n")'.
In this case ‘gitlab-merge-requests-guix-hpc-non-free-ci-doc-19’ was no
longer in the database but its monitor was still running.
* src/cuirass/base.scm (jobset-monitor): Handle 'terminate messages.
(remove-jobset): New procedure.
* src/cuirass/http.scm (url-handler): Replace uses of
‘db-remove-specification’ by 'remove-jobset messages sent to BRIDGE.
* src/cuirass/scripts/register.scm (bridge): Handle 'remove-jobset
messages.
* tests/register.scm ("remove-jobset"): New test.
* tests/http.scm (with-cuirass-register): New macro.
Wrap tests after “db-init” into ‘with-cuirass-register’.
---
src/cuirass/base.scm | 17 ++
src/cuirass/http.scm | 4 +-
src/cuirass/scripts/register.scm | 4 +
tests/http.scm | 528 ++++++++++++++++++++-------------------
tests/register.scm | 10 +-
5 files changed, 306 insertions(+), 257 deletions(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 2bc9710..ed922f1 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -78,6 +78,7 @@
lookup-jobset
register-jobset
update-jobset
+ remove-jobset
evaluation-log-file
latest-checkouts
@@ -794,6 +795,9 @@ concurrently; it sends derivation build requests to
BUILDER."
(`(last-update-times ,reply)
(put-message reply last-updates)
(loop spec last-updates))
+ ('terminate
+ (log-info "terminating monitor of jobset '~a'" name)
+ #t)
(message
(log-warning "jobset '~a' got bogus message: ~s"
name message)
@@ -813,6 +817,9 @@ concurrently; it sends derivation build requests to
BUILDER."
(`(last-update-times ,reply)
(put-message reply last-updates)
(loop spec last-updates))
+ ('terminate
+ (log-info "terminating monitor of inactive jobset '~a'" name)
+ #t)
(message
(log-warning "inactive jobset '~a' got unexpected message: ~s"
name message)
@@ -911,6 +918,16 @@ monitoring actor for each 'register' message it receives."
"Update SPEC, so far known under FORMER-NAME, in REGISTRY."
(put-message registry `(update ,spec)))
+(define (remove-jobset registry spec)
+ "Terminate the jobset monitor of SPEC, a symbol, and remove it from the
+database."
+ (match (lookup-jobset registry spec)
+ (#f
+ (log-warning "attempt to remove non-existent jobset '~a'" spec))
+ (jobset
+ (put-message jobset 'terminate)))
+ (db-remove-specification spec))
+
;;;
;;; GC root cleanup.
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 817b5be..ff2c454 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -747,7 +747,7 @@ bogus reply is received, return DEFAULT."
(let ((spec-name (specification-name spec)))
(if (db-get-specification spec-name)
(begin
- (db-remove-specification spec-name)
+ (call-bridge `(remove-jobset ,spec-name) bridge)
(log-info "Removed jobset '~a'" spec-name)
(respond
(build-response #:code 200
@@ -851,7 +851,7 @@ bogus reply is received, return DEFAULT."
#:body "Oh my, failed to activate jobset!")))
(('GET "admin" "specifications" "delete" name)
- (db-remove-specification name)
+ (call-bridge `(remove-jobset ,name) bridge)
(respond
(build-response #:code 302
#:headers
diff --git a/src/cuirass/scripts/register.scm b/src/cuirass/scripts/register.scm
index f2d0f1e..efd6a87 100644
--- a/src/cuirass/scripts/register.scm
+++ b/src/cuirass/scripts/register.scm
@@ -158,6 +158,10 @@
(log-info "triggering jobset '~a'" name)
(put-message jobset 'trigger)))
(write '(reply #t) socket))))
+ (`(remove-jobset ,name)
+ (log-info "removing jobset '~a'" name)
+ (let ((result (remove-jobset registry name)))
+ (write `(reply ,result) socket)))
(`(active-jobset? ,name)
(match (lookup-jobset registry name)
(#f
diff --git a/tests/http.scm b/tests/http.scm
index 12355b2..bcc420e 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -124,264 +124,284 @@
(gitlab-event-value
(json->gitlab-event mr-json-open))))
+(define-syntax-rule (with-cuirass-register exp ...)
+ (with-guix-daemon
+ (let ((pid #f))
+ (dynamic-wind
+ (lambda ()
+ (set! pid (spawn "cuirass"
+ (list "cuirass" "register"
+ (string-append "--database="
+ (%package-database))))))
+ (lambda ()
+ exp ...)
+ (lambda ()
+ (format (current-error-port)
+ "terminating Cuirass (PID ~a)~%" pid)
+ (kill pid SIGTERM))))))
+
(test-group-with-cleanup "http"
(test-assert "db-init"
(begin
(test-init-db!)
#t))
- (test-assert "cuirass-run"
- (call-with-new-thread
- (lambda ()
- (run-fibers
- (lambda ()
- (run-cuirass-server #:port 6688
- ;; Don't attempt to connect to the bridge.
- #:bridge-socket-file-name #f))
- #:drain? #t))))
-
- (test-assert "wait-server"
- (wait-until-ready 6688))
-
- (test-assert "fill-db"
- (let* ((build1
- (build (derivation "/gnu/store/fake.drv")
- (evaluation-id 1)
- (specification-name "guix")
- (job-name "fake-job")
- (system "x86_64-linux")
- (nix-name "fake-1.0")
- (log "unused so far")
- (status (build-status succeeded))
- (outputs
- (list (output
- (item "/gnu/store/fake-1.0")
- (derivation derivation))))
- (creation-time 1501347493)
- (start-time 1501347493)
- (completion-time 1501347493)))
- (build2
- (build (derivation "/gnu/store/fake2.drv")
- (evaluation-id 2)
- (specification-name "guix")
- (job-name "fake-job")
- (system "x86_64-linux")
- (nix-name "fake-2.0")
- (log "unused so far")
- (status (build-status scheduled))
- (outputs
- (list (output
- (item "/gnu/store/fake-2.0")
- (derivation derivation))))
- (creation-time 1501347493)))
- (build3
- (build (derivation "/gnu/store/fake3.drv")
- (evaluation-id 2)
- (specification-name "guix")
- (job-name "fake-job")
- (system "x86_64-linux")
- (nix-name "fake-3.0")
- (log "unused so far")
- (status (build-status failed)) ;failed!
- (outputs
- (list (output
- (item "/gnu/store/fake-3.0")
- (derivation derivation))))
- (creation-time 1501347493)
- (start-time creation-time)
- (completion-time (+ start-time 100))))
- (spec
- (specification
- (name "guix")
- (build 'hello)
- (channels
- (list (channel
- (name 'guix)
- (url "https://gitlab.com/mothacehe/guix.git";)
- (branch "master"))
- (channel
- (name 'packages)
- (url "https://gitlab.com/mothacehe/guix.git";)
- (branch "master"))))))
- (checkouts1
- (list
- (checkout->channel-instance "dir1"
- #:name 'guix
- #:url "url1"
- #:commit "fakesha1")
- (checkout->channel-instance "dir2"
- #:name 'packages
- #:url "url2"
- #:commit "fakesha3")))
- (checkouts2
- (list
- (checkout->channel-instance "dir3"
- #:name 'guix
- #:url "dir3"
- #:commit "fakesha2")
- (checkout->channel-instance "dir4"
- #:name 'packages
- #:url "dir4"
- #:commit "fakesha3"))))
- (db-add-or-update-specification spec)
- (db-add-evaluation "guix" checkouts1
- #:timestamp 1501347493)
- (db-add-evaluation "guix" checkouts2
- #:timestamp 1501347493)
- (db-add-build build1)
- (db-add-build build2)
- (db-add-build build3)))
-
- (test-assert "/specifications"
- (match (call-with-input-string
- (utf8->string
- (http-get-body (test-cuirass-uri "/specifications")))
- json->scm)
- (#(spec)
- (string=? (assoc-ref spec "name") "guix"))))
-
- (test-assert "/build/1"
- (lset= equal?
- (call-with-input-string
- (utf8->string
- (http-get-body (test-cuirass-uri "/build/1")))
- json->scm)
- (call-with-input-string
- (scm->json-string build-query-result)
- json->scm)))
-
- (test-equal "/build/1/restart redirects to /admin"
- (list 302 "/admin/build/1/restart" (build-status succeeded))
-
- ;; This is a successful build so /build/1/restart redirects to /admin
- ;; without doing anything.
- (let ((response (http-get (test-cuirass-uri "/build/1/restart"))))
- (list (response-code response)
- (uri-path (response-location response))
- (build-current-status (db-get-build 1)))))
-
- (test-equal "/build/3/restart is unprivileged (failed build)"
- (list 302 "/build/3/details" (build-status scheduled))
-
- ;; This is a short and failed build so /build/3/restart actually
- ;; reschedules it.
- (let ((response (http-get (test-cuirass-uri "/build/3/restart"))))
- (list (response-code response)
- (uri-path (response-location response))
- (build-current-status (db-get-build 3)))))
-
- (test-equal "/build/42"
- 404
- (response-code (http-get (test-cuirass-uri "/build/42"))))
-
- (test-equal "/build/42)"
- 404
- (response-code (http-get (test-cuirass-uri "/build/42)"))))
-
- (test-equal "/build/42/log/raw"
- 404
- (response-code (http-get (test-cuirass-uri "/build/42/log/raw"))))
-
- (test-equal "/build/42xx/log/raw"
- 404
- (response-code (http-get (test-cuirass-uri "/build/42xx/log/raw"))))
-
- (test-equal "/build/42/details"
- 404
- (response-code (http-get (test-cuirass-uri "/build/42/details"))))
-
- (test-equal "/build/42xx/details"
- 404
- (response-code (http-get (test-cuirass-uri "/build/42xx/details"))))
-
- (test-equal "/api/latestbuilds"
- 500
- (response-code (http-get (test-cuirass-uri "/api/latestbuilds"))))
-
- (test-assert "/api/latestbuilds?nr=1&jobset=guix"
- (match (json-string->scm
- (utf8->string
- (http-get-body
- (test-cuirass-uri
- "/api/latestbuilds?nr=1&jobset=guix"))))
- (#(build)
- (lset= equal? build
- (json-string->scm
- (scm->json-string build-query-result))))))
-
- (test-equal "/api/latestbuilds?nr=1&jobset=gnu"
- #() ;the result should be an empty JSON array
- (json-string->scm
- (utf8->string
- (http-get-body
+ (with-cuirass-register
+
+ (test-assert "bridge ready"
+ (wait-for-bridge))
+
+ (test-assert "cuirass-run"
+ (call-with-new-thread
+ (lambda ()
+ (run-fibers
+ (lambda ()
+ (run-cuirass-server #:port 6688))
+ #:drain? #t))))
+
+ (test-assert "wait-server"
+ (wait-until-ready 6688))
+
+ (test-assert "fill-db"
+ (let* ((build1
+ (build (derivation "/gnu/store/fake.drv")
+ (evaluation-id 1)
+ (specification-name "guix")
+ (job-name "fake-job")
+ (system "x86_64-linux")
+ (nix-name "fake-1.0")
+ (log "unused so far")
+ (status (build-status succeeded))
+ (outputs
+ (list (output
+ (item "/gnu/store/fake-1.0")
+ (derivation derivation))))
+ (creation-time 1501347493)
+ (start-time 1501347493)
+ (completion-time 1501347493)))
+ (build2
+ (build (derivation "/gnu/store/fake2.drv")
+ (evaluation-id 2)
+ (specification-name "guix")
+ (job-name "fake-job")
+ (system "x86_64-linux")
+ (nix-name "fake-2.0")
+ (log "unused so far")
+ (status (build-status scheduled))
+ (outputs
+ (list (output
+ (item "/gnu/store/fake-2.0")
+ (derivation derivation))))
+ (creation-time 1501347493)))
+ (build3
+ (build (derivation "/gnu/store/fake3.drv")
+ (evaluation-id 2)
+ (specification-name "guix")
+ (job-name "fake-job")
+ (system "x86_64-linux")
+ (nix-name "fake-3.0")
+ (log "unused so far")
+ (status (build-status failed)) ;failed!
+ (outputs
+ (list (output
+ (item "/gnu/store/fake-3.0")
+ (derivation derivation))))
+ (creation-time 1501347493)
+ (start-time creation-time)
+ (completion-time (+ start-time 100))))
+ (spec
+ (specification
+ (name "guix")
+ (build 'hello)
+ (channels
+ (list (channel
+ (name 'guix)
+ (url "https://gitlab.com/mothacehe/guix.git";)
+ (branch "master"))
+ (channel
+ (name 'packages)
+ (url "https://gitlab.com/mothacehe/guix.git";)
+ (branch "master"))))))
+ (checkouts1
+ (list
+ (checkout->channel-instance "dir1"
+ #:name 'guix
+ #:url "url1"
+ #:commit "fakesha1")
+ (checkout->channel-instance "dir2"
+ #:name 'packages
+ #:url "url2"
+ #:commit "fakesha3")))
+ (checkouts2
+ (list
+ (checkout->channel-instance "dir3"
+ #:name 'guix
+ #:url "dir3"
+ #:commit "fakesha2")
+ (checkout->channel-instance "dir4"
+ #:name 'packages
+ #:url "dir4"
+ #:commit "fakesha3"))))
+ (db-add-or-update-specification spec)
+ (db-add-evaluation "guix" checkouts1
+ #:timestamp 1501347493)
+ (db-add-evaluation "guix" checkouts2
+ #:timestamp 1501347493)
+ (db-add-build build1)
+ (db-add-build build2)
+ (db-add-build build3)))
+
+ (test-assert "/specifications"
+ (match (call-with-input-string
+ (utf8->string
+ (http-get-body (test-cuirass-uri "/specifications")))
+ json->scm)
+ (#(spec)
+ (string=? (assoc-ref spec "name") "guix"))))
+
+ (test-assert "/build/1"
+ (lset= equal?
+ (call-with-input-string
+ (utf8->string
+ (http-get-body (test-cuirass-uri "/build/1")))
+ json->scm)
+ (call-with-input-string
+ (scm->json-string build-query-result)
+ json->scm)))
+
+ (test-equal "/build/1/restart redirects to /admin"
+ (list 302 "/admin/build/1/restart" (build-status succeeded))
+
+ ;; This is a successful build so /build/1/restart redirects to /admin
+ ;; without doing anything.
+ (let ((response (http-get (test-cuirass-uri "/build/1/restart"))))
+ (list (response-code response)
+ (uri-path (response-location response))
+ (build-current-status (db-get-build 1)))))
+
+ (test-equal "/build/3/restart is unprivileged (failed build)"
+ (list 302 "/build/3/details" (build-status scheduled))
+
+ ;; This is a short and failed build so /build/3/restart actually
+ ;; reschedules it.
+ (let ((response (http-get (test-cuirass-uri "/build/3/restart"))))
+ (list (response-code response)
+ (uri-path (response-location response))
+ (build-current-status (db-get-build 3)))))
+
+ (test-equal "/build/42"
+ 404
+ (response-code (http-get (test-cuirass-uri "/build/42"))))
+
+ (test-equal "/build/42)"
+ 404
+ (response-code (http-get (test-cuirass-uri "/build/42)"))))
+
+ (test-equal "/build/42/log/raw"
+ 404
+ (response-code (http-get (test-cuirass-uri "/build/42/log/raw"))))
+
+ (test-equal "/build/42xx/log/raw"
+ 404
+ (response-code (http-get (test-cuirass-uri "/build/42xx/log/raw"))))
+
+ (test-equal "/build/42/details"
+ 404
+ (response-code (http-get (test-cuirass-uri "/build/42/details"))))
+
+ (test-equal "/build/42xx/details"
+ 404
+ (response-code (http-get (test-cuirass-uri "/build/42xx/details"))))
+
+ (test-equal "/api/latestbuilds"
+ 500
+ (response-code (http-get (test-cuirass-uri "/api/latestbuilds"))))
+
+ (test-assert "/api/latestbuilds?nr=1&jobset=guix"
+ (match (json-string->scm
+ (utf8->string
+ (http-get-body
+ (test-cuirass-uri
+ "/api/latestbuilds?nr=1&jobset=guix"))))
+ (#(build)
+ (lset= equal? build
+ (json-string->scm
+ (scm->json-string build-query-result))))))
+
+ (test-equal "/api/latestbuilds?nr=1&jobset=gnu"
+ #() ;the result should be an empty JSON array
+ (json-string->scm
+ (utf8->string
+ (http-get-body
+ (test-cuirass-uri
+ "/api/latestbuilds?nr=1&jobset=gnu")))))
+
+ (test-equal "/api/latestbuilds?nr&jobset=gnu"
+ 500
+ (response-code
+ (http-get
(test-cuirass-uri
- "/api/latestbuilds?nr=1&jobset=gnu")))))
-
- (test-equal "/api/latestbuilds?nr&jobset=gnu"
- 500
- (response-code
- (http-get
- (test-cuirass-uri
- "/api/latestbuilds?nr&jobset=gnu"))))
-
- (test-equal "/api/queue?nr=100"
- `(("fake-2.0" ,(build-status scheduled))
- ("fake-3.0" ,(build-status scheduled)))
- (match (json-string->scm
- (utf8->string
- (http-get-body
- (test-cuirass-uri "/api/queue?nr=100"))))
- (#(first second)
- (list (list (assoc-ref first "nixname")
- (assoc-ref first "buildstatus"))
- (list (assoc-ref second "nixname")
- (assoc-ref second "buildstatus"))))))
-
- (test-equal "/api/evaluations?nr=1"
- (json-string->scm
- (scm->json-string evaluations-query-result))
- (json-string->scm
- (utf8->string
- (http-get-body (test-cuirass-uri "/api/evaluations?nr=1")))))
-
- (test-equal "/api/jobs/history"
- '#((("jobs" . #((("status" . 0) ("build" . 1) ("name" . "fake-job"))))
- ("checkouts" . #((("directory" . "dir1") ("channel" . "guix")
- ("commit" . "fakesha1"))
- (("directory" . "dir2") ("channel" . "packages")
- ("commit" . "fakesha3"))))
- ("evaluation" . 1)))
- (begin
- (db-register-builds (list (db-get-build "/gnu/store/fake.drv"))
- (db-get-specification "guix"))
- (db-set-evaluation-status 1 (evaluation-status succeeded))
- (db-update-build-status! "/gnu/store/fake.drv"
- (build-status succeeded))
- (json-string->scm
- (utf8->string
- (http-get-body
- (test-cuirass-uri
"/api/jobs/history?spec=guix&names=fake-job&nr=10"))))))
-
- (test-equal "/admin/gitlab/event creates a spec from a new merge request"
- (specification-name mr-spec)
- (begin
- (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-open)
- (specification-name (db-get-specification (specification-name
mr-spec)))))
-
- (test-equal "/admin/gitlab/event error when a merge request has already been
created"
- 400
- (response-code (http-post-json (test-cuirass-uri "/admin/gitlab/event")
mr-json-open)))
-
- (test-assert "/admin/gitlab/event removes a spec from a closed merge request"
- (begin
- (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-close)
- (not (db-get-specification (specification-name mr-spec)))))
-
- (test-equal "/admin/gitlab/event error when a merge request has already been
closed"
- 404
- (response-code (http-post-json (test-cuirass-uri "/admin/gitlab/event")
mr-json-close)))
-
- (test-assert "db-close"
- (begin
- (db-close (%db))
- #t)))
+ "/api/latestbuilds?nr&jobset=gnu"))))
+
+ (test-equal "/api/queue?nr=100"
+ `(("fake-2.0" ,(build-status scheduled))
+ ("fake-3.0" ,(build-status scheduled)))
+ (match (json-string->scm
+ (utf8->string
+ (http-get-body
+ (test-cuirass-uri "/api/queue?nr=100"))))
+ (#(first second)
+ (list (list (assoc-ref first "nixname")
+ (assoc-ref first "buildstatus"))
+ (list (assoc-ref second "nixname")
+ (assoc-ref second "buildstatus"))))))
+
+ (test-equal "/api/evaluations?nr=1"
+ (json-string->scm
+ (scm->json-string evaluations-query-result))
+ (json-string->scm
+ (utf8->string
+ (http-get-body (test-cuirass-uri "/api/evaluations?nr=1")))))
+
+ (test-equal "/api/jobs/history"
+ '#((("jobs" . #((("status" . 0) ("build" . 1) ("name" . "fake-job"))))
+ ("checkouts" . #((("directory" . "dir1") ("channel" . "guix")
+ ("commit" . "fakesha1"))
+ (("directory" . "dir2") ("channel" . "packages")
+ ("commit" . "fakesha3"))))
+ ("evaluation" . 1)))
+ (begin
+ (db-register-builds (list (db-get-build "/gnu/store/fake.drv"))
+ (db-get-specification "guix"))
+ (db-set-evaluation-status 1 (evaluation-status succeeded))
+ (db-update-build-status! "/gnu/store/fake.drv"
+ (build-status succeeded))
+ (json-string->scm
+ (utf8->string
+ (http-get-body
+ (test-cuirass-uri
"/api/jobs/history?spec=guix&names=fake-job&nr=10"))))))
+
+ (test-equal "/admin/gitlab/event creates a spec from a new merge request"
+ (specification-name mr-spec)
+ (begin
+ (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-open)
+ (specification-name (db-get-specification (specification-name
mr-spec)))))
+
+ (test-equal "/admin/gitlab/event error when a merge request has already
been created"
+ 400
+ (response-code (http-post-json (test-cuirass-uri "/admin/gitlab/event")
mr-json-open)))
+
+ (test-assert "/admin/gitlab/event removes a spec from a closed merge
request"
+ (begin
+ (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-close)
+ (not (db-get-specification (specification-name mr-spec)))))
+
+ (test-equal "/admin/gitlab/event error when a merge request has already
been closed"
+ 404
+ (response-code (http-post-json (test-cuirass-uri "/admin/gitlab/event")
+ mr-json-close)))
+
+ (test-assert "db-close"
+ (begin
+ (db-close (%db))
+ #t))))
diff --git a/tests/register.scm b/tests/register.scm
index 7e97ee9..738a2fb 100644
--- a/tests/register.scm
+++ b/tests/register.scm
@@ -74,7 +74,7 @@
%client-socket))
(unless (file-port? %client-socket)
- (test-skip 1))
+ (test-skip 2))
(test-assert "active-jobset?"
(retry
@@ -86,6 +86,14 @@
#:times 5
#:delay 1))
+ (test-equal "remove-jobset"
+ '()
+ (begin
+ (write '(remove-jobset random) %client-socket)
+ (match (read %client-socket)
+ (('reply 1) #t))
+ (db-get-specifications)))
+
(test-equal "process terminated"
(cons %pid SIGKILL)
(begin
