Subject: [PATCH Cuirass 11/13] forges: notification: Add forge notification actor.

From: Romain GARBAGE <[email-masked]>
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 <[email-masked]>
+;;;
+;;; 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 <[email-masked]>
+;;;
+;;; 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