Package: guix-patches;
Reported by: Romain GARBAGE <romain.garbage <at> inria.fr>
Date: Tue, 11 Mar 2025 10:34:01 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Romain GARBAGE <romain.garbage <at> inria.fr> To: 76938 <at> debbugs.gnu.org Cc: ludovic.courtes <at> inria.fr, Romain GARBAGE <romain.garbage <at> inria.fr> Subject: [bug#76938] [PATCH Cuirass 11/13] forges: notification: Add forge notification actor. Date: Tue, 11 Mar 2025 11:34:36 +0100
* src/cuirass/forges/notification.scm: New file. (%forge-notification-handlers, forge-notification-service, spawn-forge-notification-service): New variables. * tests/forges-notification.scm: New file. * Makefile.am (dist_forgesmodule_DATA): Add new file. (TESTS): Add tests/forges-notification.scm. --- Makefile.am | 4 +- src/cuirass/forges/notification.scm | 178 ++++++++++++++++++++++++++++ tests/forges-notification.scm | 119 +++++++++++++++++++ 3 files changed, 300 insertions(+), 1 deletion(-) create mode 100644 src/cuirass/forges/notification.scm create mode 100644 tests/forges-notification.scm diff --git a/Makefile.am b/Makefile.am index 75b406f..0c2ab95 100644 --- a/Makefile.am +++ b/Makefile.am @@ -79,7 +79,8 @@ dist_scriptsmodule_DATA = \ dist_forgesmodule_DATA = \ src/cuirass/forges/forgejo.scm \ - src/cuirass/forges/gitlab.scm + src/cuirass/forges/gitlab.scm \ + src/cuirass/forges/notification.scm nodist_pkgmodule_DATA = \ src/cuirass/config.scm @@ -182,6 +183,7 @@ TESTS = \ tests/store.scm \ tests/database.scm \ tests/forgejo.scm \ + tests/forges-notification.scm \ tests/gitlab.scm \ tests/http.scm \ tests/metrics.scm \ diff --git a/src/cuirass/forges/notification.scm b/src/cuirass/forges/notification.scm new file mode 100644 index 0000000..ca7ed7b --- /dev/null +++ b/src/cuirass/forges/notification.scm @@ -0,0 +1,178 @@ +;;; notification.scm -- Notification mechanism for forges. +;;; Copyright © 2025 Romain Garbage <romain.garbage <at> inria.fr> +;;; +;;; This file is part of Cuirass. +;;; +;;; Cuirass is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Cuirass 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>. + +(define-module (cuirass forges notification) + #:use-module (cuirass database) + #:use-module (cuirass forges forgejo) + #:use-module (cuirass logging) + #:use-module (cuirass specification) + #:use-module (fibers) + #:use-module (fibers channels) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-71) + #:export (forge-notification-service + spawn-forge-notification-service)) + +;;; Commentary: +;;; +;;; This module implements procedures and variables used by the +;;; forge-notification-service. +;;; +;;; Code: + +;;; +;;; Forge communication. +;;; + +;; A-list of supported forges for the notification service associated with +;; their handler. Handlers are procedures expected to have the following +;; signature: +;; +;; (handler spec +;; #:key (jobset-created #f) +;; (evaluation-started #f) +;; (evaluation-succeeded #f) +;; (evaluation-failed #f) +;; (build-results #f)) +;; +;; with: +;; - SPEC, a specification record +;; - JOBSET-CREATED, a boolean +;; - EVALUATION-STARTED, a number (evaluation-id) +;; - EVALUATION-SUCCEEDED, a number (evaluation-id) +;; - EVALUATION-FAILED, a number (evaluation-id) +;; - BUILD-RESULTS, a list of BUILD records +(define %forge-notification-handlers + '()) + +;; The jobset monitor spawns a forge-notification-service instance and subscribes it +;; to the event-log-service that forwards a copy of every newly created event +;; to its subscribers, in particular: +;; - jobset creation +;; - jobset evaluation started +;; - jobset evaluation completed +;; - build results +(define* (forge-notification-service channel spec + #:optional + (forge-notification-handlers %forge-notification-handlers)) + "Spawn a forge notification agent that listens to events on CHANNEL and +communicates with the forge defined in SPEC properties. The agent handles +generic events and relies on forge-specific handlers to communicate with the +forge. These specific are expected to raise an error if there is any issue +when communcating with the forge." + (lambda () + (define start-time (time-second (current-time time-utc))) + (define forge-type (assoc-ref (specification-properties spec) + 'forge-type)) + ;; Can't be FALSE because it is checked by + ;; SPAWN-FORGE-NOTIFICATION-SERVICE below. + (define handler (assoc-ref forge-notification-handlers forge-type)) + + (let loop ((spec spec) + ;; Keeps track of the evaluations related to our + ;; specification. + (evaluation-ids '()) + ;; Keeps track of the build results related to our + ;; specification. + (build-results '())) + (let* ((name (specification-name spec)) + (jobset-matches? (lambda (jobset) + (eq? (specification-name jobset) + name))) + (build-matches? (lambda (build) + (find (lambda (evaluation-id) + (= (build-evaluation-id build) + evaluation-id)) + evaluation-ids))) + (updated-build-results (lambda (build) + (filter (lambda (existing-build) + ;; Remove builds that have + ;; the same nix-name and a + ;; lower evaluation-id. + ;; Keep the rest. + (not (and (string=? (build-nix-name existing-build) + (build-nix-name build)) + (< (build-evaluation-id existing-build) + (build-evaluation-id build))))) + (cons build build-results))))) + + (guard (c (#t ; catch all + (log-error "forge-notification-service: ~s" c))) + (match (get-message channel) + (`(jobset-created ,timestamp ,jobset) + (when (jobset-matches? jobset) + (handler spec #:jobset-created #t)) + (loop spec evaluation-ids build-results)) + + (`(jobset-updated ,timestamp ,updated-spec) + (if (jobset-matches? updated-spec) + (loop updated-spec evaluation-ids build-results) + (loop spec evaluation-ids build-results))) + + (`(evaluation-started ,timestamp ,evaluation-id ,evaluated-spec) + (when (jobset-matches? evaluated-spec) + (handler spec #:evaluation-started evaluation-id)) + (loop spec evaluation-ids build-results)) + + (`(evaluation-completed ,timestamp ,evaluation-id ,evaluated-spec) + (when (jobset-matches? evaluated-spec) + ;; (= 0 status) is success. + (if (= 0 (evaluation-current-status + (db-get-evaluation evaluation-id))) + (begin (handler spec #:evaluation-succeeded evaluation-id) + (loop spec (cons evaluation-id evaluation-ids) build-results)) + (begin (handler spec #:evaluation-failed evaluation-id) + (loop spec evaluation-ids build-results)))) + (loop spec evaluation-ids build-results)) + + (`(build-status-changed ,timestamp ,build) + (let* ((evaluation-id (build-evaluation-id build)) + (build-results (if (build-matches? build) + (updated-build-results (build)) + build-results)) + (summaries (map db-get-evaluation-summary + evaluation-ids)) + (pending-builds (reduce + 0 (map evaluation-summary-scheduled + summaries)))) + (when (= 0 pending-builds) + (handler spec #:build-results build-results)) + (loop spec evaluation-ids build-results))) + + (message + (log-info "nothing to do for ~s" message) + (loop spec evaluation-ids build-results)))))))) + +(define (spawn-forge-notification-service spec) + "Spawn a forge notification actor that communicates Cuirass events to external +forges." + (let* ((channel (make-channel)) + (properties (specification-properties spec)) + (forge-type (assoc-ref properties 'forge-type))) + (if (assoc-ref %forge-notification-handlers forge-type) + (begin + (log-info "spawning forge notif for ~a" (specification-name spec)) + (spawn-fiber (forge-notification-service channel spec)) + channel) + (begin + ;; Don't start the fiber when the forge type is not supported. + (log-info "forge type ~a not implemented in forge-notification-service (spec ~a), not starting the forge-notification-service" + forge-type (specification-name spec)) + #f)))) diff --git a/tests/forges-notification.scm b/tests/forges-notification.scm new file mode 100644 index 0000000..fff10ee --- /dev/null +++ b/tests/forges-notification.scm @@ -0,0 +1,119 @@ +;;; forges-notification.scm -- tests for (cuirass forges notification) module +;;; Copyright © 2025 Romain GARBAGE <romain.garbage <at> inria.fr> +;;; +;;; This file is part of Cuirass. +;;; +;;; Cuirass is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Cuirass 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Cuirass. If not, see <http://www.gnu.org/ + +(use-modules (cuirass forges notification) + (cuirass specification) + (cuirass tests http) + (fibers) + (fibers channels) + (guix channels) + (ice-9 match)) + +(test-equal "spawn-forge-notification-service: undefined forge-type property" + #f + (let ((spec (specification + (name 'specification-name) + (build '(channels . (project-name))) + (channels + (cons* (channel + (name 'project-name) + (url "https://instance.local/path/to/channel") + (branch "test-branch")) + %default-channels))))) + (run-fibers (lambda () + (spawn-forge-notification-service spec))))) + +(test-equal "spawn-forge-notification-service: unsupported forge-type property" + #f + (let ((spec (specification + (name 'specification-name) + (build '(channels . (project-name))) + (channels + (cons* (channel + (name 'project-name) + (url "https://instance.local/path/to/channel") + (branch "test-branch")) + %default-channels)) + (properties '((forge-type . unsupported-forge)))))) + (run-fibers (lambda () + (spawn-forge-notification-service spec))))) + +;; This block defines a FORGE-TYPE with its associated notification handler +;; procedure. It is used to check code paths in the forge-notification-service +;; procedure. +(let* ((forge-type 'mock-type) + (spec (specification + (name 'specification-name) + (build '(channels . (project-name))) + (channels + (cons* (channel + (name 'project-name) + (url "https://instance.local/path/to/channel") + (branch "test-branch")) + %default-channels)) + (properties `((forge-type . ,forge-type))))) + (channel (make-channel)) + (%handler-values '()) + ;; This defines a forge handler that returns the value associated with + ;; a specific key. + (forge-handler (lambda* (spec + #:key + jobset-created + evaluation-started + evaluation-succeeded + evaluation-failed + build-results) + (format #t "forge-handler started for ~a~%" (specification-name spec)) + (let ((return-value (match (list jobset-created + evaluation-started + evaluation-succeeded + evaluation-failed + build-results) + ((#f #f #f #f #f) + 'no-provided-value-error) + ((jobset-created #f #f #f #f) + jobset-created) + ((#f evaluation-started #f #f #f) + evaluation-started) + ((#f #f evaluation-succeeded #f #f) + evaluation-succeeded) + ((#f #f #f evaluation-failed #f) + evaluation-failed) + ((#f #f #f #f build-results) + build-results) + (_ + 'more-than-one-key-error)))) + (set! %handler-values + (cons return-value %handler-values))) + (format #t "%return-values: ~s" + %handler-values))) + (notification-handlers `((,forge-type . ,forge-handler)))) + + (test-equal "forge-notification-service: message handling without database" + (list 1 #t) + (run-fibers + (lambda () + (spawn-fiber (forge-notification-service channel spec notification-handlers)) + (put-message channel `(jobset-created 0 ,spec)) + (put-message channel `(evaluation-started 0 1 ,spec)) + ;; XXX: These need to communicate with the database. + ;; (put-message channel `(evaluation-completed 0 2 ,spec)) + ;; (put-message channel `(evaluation-failed 0 3 ,spec)) + ;; (put-message channel `(build-status-changed 0 ,spec)) + (sleep 1) ; wait for the fiber to proceed messages. + %handler-values)))) -- 2.48.1
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.