[PATCH Cuirass 00/13] Forges notification support.

  • Open
  • quality assurance status badge
Details
One participant
  • Romain GARBAGE
Owner
unassigned
Submitted by
Romain GARBAGE
Severity
normal

Debbugs page

Romain GARBAGE wrote 25 hours ago
(address . guix-patches@gnu.org)
20250311103218.28873-1-romain.garbage@inria.fr
This patch series adds a generic mechanism for notifying forges about
Cuirass results in association to a PR-associated jobset.

It also adds support for notification to Forgejo based forges such as
Codeberg.

Romain GARBAGE (13):
cuirass: config: Add %sysconfdir.
forges: Add support for token storage.
tests: forgejo: Explicit test name.
cuirass: tests: Add mock HTTP server for tests.
tests: Move common module to src/cuirass/tests.
forgejo: Add API communication primitive.
forgejo: Add pull request API manipulation procedures.
forgejo: Extend specification properties content.
forgejo: Add pull request update procedures.
database: Export build-failure?.
forges: notification: Add forge notification actor.
forgejo: Add notification handling.
base: Add support for forge notification in jobset-monitor.

Makefile.am | 8 +-
src/cuirass/base.scm | 19 ++
src/cuirass/config.scm.in | 5 +
src/cuirass/database.scm | 1 +
src/cuirass/forges.scm | 47 +++-
src/cuirass/forges/forgejo.scm | 280 +++++++++++++++++++++++-
src/cuirass/forges/notification.scm | 178 +++++++++++++++
{tests => src/cuirass/tests}/common.scm | 2 +-
src/cuirass/tests/http.scm | 192 ++++++++++++++++
tests/database.scm | 2 +-
tests/forgejo.scm | 151 ++++++++++++-
tests/forges-notification.scm | 119 ++++++++++
tests/gitlab.scm | 2 +-
tests/http.scm | 16 +-
tests/metrics.scm | 2 +-
tests/register.scm | 2 +-
tests/remote.scm | 2 +-
17 files changed, 1005 insertions(+), 23 deletions(-)
create mode 100644 src/cuirass/forges/notification.scm
rename {tests => src/cuirass/tests}/common.scm (99%)
create mode 100644 src/cuirass/tests/http.scm
create mode 100644 tests/forges-notification.scm


base-commit: 520b2fdbd96e953fc2d4b56e78e52a81fc11e2b7
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 02/13] forges: Add support for token storage.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-2-romain.garbage@inria.fr
* src/cuirass/forges.scm (%forge-token-directory, forge-get-token): New variables.
---
src/cuirass/forges.scm | 47 ++++++++++++++++++++++++++++++++++++++++--
1 file changed, 45 insertions(+), 2 deletions(-)

Toggle diff (82 lines)
diff --git a/src/cuirass/forges.scm b/src/cuirass/forges.scm
index 540315b..3f6a818 100644
--- a/src/cuirass/forges.scm
+++ b/src/cuirass/forges.scm
@@ -1,5 +1,5 @@
;;; forges.scm -- Common forges utilities
-;;; Copyright © 2024 Romain Garbage <romain.garbage@inria.fr>
+;;; Copyright © 2024-2025 Romain Garbage <romain.garbage@inria.fr>
;;;
;;; This file is part of Cuirass.
;;;
@@ -18,9 +18,12 @@
(define-module (cuirass forges)
#:use-module ((guix utils) #:select (%current-system))
+ #:use-module (cuirass config)
#:use-module (cuirass specification)
+ #:use-module (cuirass logging)
#:use-module (json)
#:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
#:export (%default-jobset-options-period
%default-jobset-options-priority
%default-jobset-options-systems
@@ -32,7 +35,10 @@
jobset-options-build
jobset-options-period
jobset-options-priority
- jobset-options-systems))
+ jobset-options-systems
+
+ forge-get-token
+ %forge-token-directory))
;;; Commentary:
;;;
@@ -51,6 +57,43 @@
(define %default-jobset-options-systems
(list (%current-system)))
+;; Path to the base directory containing the tokens. Each file inside that
+;; directory should be named after the host-name of the forge and should
+;; contain one token definition per line. A token definition consists of a
+;; namespace (e.g org/project) and a token.
+(define %forge-token-directory
+ (make-parameter (in-vicinity %sysconfdir "cuirass/forge-tokens")))
+
+(define (forge-get-token host-name namespace)
+ "Return a token as a string for the requested couple HOST-NAME and NAMESPACE,
+both strings. As an exemple, a token for a Git repository located at
+\"https://codeberg.org/owner/repo\" could be retrieved by setting HOST-NAME to
+\"codeberg.org\" and NAMESPACE to \"owner/repo\"."
+ (let ((file-name (string-append (%forge-token-directory)
+ "/"
+ host-name)))
+ (call-with-input-file file-name
+ (lambda (port)
+ (let loop ()
+ (match (read-line port)
+ ((? eof-object?) #f)
+ (str
+ (let ((str (string-trim-both str)))
+ (if (or (string-null? str)
+ (string-prefix? "#" str))
+ (loop)
+ (match (string-tokenize str)
+ (`(,ns ,token)
+ (if (string=? ns namespace)
+ token
+ (loop)))
+ (_
+ (log-warning "Malformed line ~a in file ~a.~%"
+ (port-line port)
+ file-name)
+ (loop)))))))))
+ #:encoding "utf-8")))
+
;; This mapping defines a specific JSON dictionary used for tweaking Cuirass
;; options. It is not included in the JSON data sent by default by Gitlab and
;; must be used through the custom template mechanism (see documentation).
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 03/13] tests: forgejo: Explicit test name.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-3-romain.garbage@inria.fr
* tests/forgejo.scm : Explicit test name.
---
tests/forgejo.scm | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)

Toggle diff (23 lines)
diff --git a/tests/forgejo.scm b/tests/forgejo.scm
index 2718bb3..10f183a 100644
--- a/tests/forgejo.scm
+++ b/tests/forgejo.scm
@@ -1,5 +1,5 @@
-;;; forgejo.scm -- tests for (cuirass forgejo) module
-;;; Copyright © 2024 Romain GARBAGE <romain.garbage@inria.fr>
+;;; forgejo.scm -- tests for (cuirass forges forgejo) module
+;;; Copyright © 2024-2025 Romain GARBAGE <romain.garbage@inria.fr>
;;;
;;; This file is part of Cuirass.
;;;
@@ -64,7 +64,7 @@
}
}")
-(test-assert "default-json"
+(test-assert "forgejo-pull-request->specification: default-json"
(specifications=?
(let ((event (json->forgejo-pull-request-event default-pull-request-json)))
(forgejo-pull-request->specification
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 04/13] cuirass: tests: Add mock HTTP server for tests.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-4-romain.garbage@inria.fr
* src/cuirass/tests/http.scm: New module.
(%http-server-port, open-http-server-socket, %local-url, %received-requests+request-bodies, call-with-http-server, with-http-server): New variables.
* Makefile.am (nodist_noinst_DATA): Declare new module to the build system.
---
Makefile.am | 3 +
src/cuirass/tests/http.scm | 192 +++++++++++++++++++++++++++++++++++++
2 files changed, 195 insertions(+)
create mode 100644 src/cuirass/tests/http.scm

Toggle diff (214 lines)
diff --git a/Makefile.am b/Makefile.am
index d5bb509..e1d2cb6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -100,6 +100,9 @@ nodist_scriptsobject_DATA = \
nodist_webobject_DATA = \
$(dist_webmodule_DATA:.scm=.go)
+nodist_noinst_DATA = \
+ src/cuirass/tests/http.scm
+
dist_pkgdata_DATA = src/schema.sql
dist_sql_DATA = \
diff --git a/src/cuirass/tests/http.scm b/src/cuirass/tests/http.scm
new file mode 100644
index 0000000..62b0910
--- /dev/null
+++ b/src/cuirass/tests/http.scm
@@ -0,0 +1,192 @@
+;;; http.scm -- HTTP mock server for tests.
+;;; Copyright © 2014-2017, 2019, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2025 Romain Garbage <romain.garbage@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 tests http)
+ #:use-module (ice-9 threads)
+ #:use-module (web server)
+ #:use-module (web server http)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (ice-9 match)
+ #:export (with-http-server
+ call-with-http-server
+ %http-server-port
+ %local-url
+ %last-request
+ %last-request-body))
+
+
+;;;
+;;; Mock HTTP server.
+;;; Adapted from (guix tests http) module.
+;;;
+
+(define %http-server-port
+ ;; TCP port to use for the stub HTTP server.
+ ;; If 0, the OS will automatically choose
+ ;; a port.
+ (make-parameter 0))
+
+(define (open-http-server-socket)
+ "Return a listening socket for the web server and the port
+actually listened at (in case %http-server-port was 0)."
+ (catch 'system-error
+ (lambda ()
+ (let ((sock (socket PF_INET SOCK_STREAM 0)))
+ (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+ (bind sock
+ (make-socket-address AF_INET INADDR_LOOPBACK
+ (%http-server-port)))
+ (values sock
+ (sockaddr:port (getsockname sock)))))
+ (lambda args
+ (let ((err (system-error-errno args)))
+ (format (current-error-port)
+ "warning: cannot run Web server for tests: ~a~%"
+ (strerror err))
+ (values #f #f)))))
+
+(define* (%local-url #:optional (port (%http-server-port))
+ #:key (path "/foo/bar"))
+ (when (= port 0)
+ (error "no web server is running!"))
+ ;; URL to use for 'home-page' tests.
+ (string-append "http://localhost:" (number->string port)
+ path))
+
+(define %received-requests+request-bodies '())
+
+(define* (call-with-http-server responses+data thunk)
+ "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
+requests. Each element of RESPONSES+DATA must be a tuple containing a
+response and a string, or an HTTP response code and a string.
+
+%http-server-port will be set to the port listened at
+The port listened at will be set for the dynamic extent of THUNK."
+ (define responses
+ (map (match-lambda
+ (((? response? response) data)
+ (list response data))
+ (((? integer? code) data)
+ (list (build-response #:code code
+ #:reason-phrase "Such is life")
+ data))
+ (((? string? path) (? integer? code) data)
+ (list path
+ (build-response #:code code
+ #:headers
+ (if (string? data)
+ '()
+ '((content-type ;binary data
+ . (application/octet-stream
+ (charset
+ . "ISO-8859-1")))))
+ #:reason-phrase "Such is life")
+ data)))
+ responses+data))
+
+ (define (http-write server client response body)
+ "Write RESPONSE."
+ (let* ((response (write-response response client))
+ (port (response-port response)))
+ (cond
+ ((not body)) ;pass
+ (else
+ (write-response-body response body)))
+ (close-port port)
+ (when (null? responses)
+ (quit #t)) ;exit the server thread
+ (values)))
+
+ (define (http-read server)
+ (let-values (((client request body) ((@@ (web server http) http-read) server)))
+ (set! %received-requests+request-bodies
+ (acons request
+ body
+ %received-requests+request-bodies))
+ (values client request body)))
+
+ ;; Mutex and condition variable to synchronize with the HTTP server.
+ (define %http-server-lock (make-mutex))
+ (define %http-server-ready (make-condition-variable))
+ (define %http-real-server-port #f)
+
+ (define (http-open . args)
+ "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
+ (with-mutex %http-server-lock
+ (let ((result (apply (@@ (web server http) http-open) args)))
+ (signal-condition-variable %http-server-ready)
+ result)))
+
+ (define-server-impl stub-http-server
+ ;; Stripped-down version of Guile's built-in HTTP server.
+ http-open
+ http-read
+ http-write
+ (@@ (web server http) http-close))
+
+ (define bad-request
+ (build-response #:code 400 #:reason-phrase "Unexpected request"))
+
+ (define (server-body)
+ (define (handle request body)
+ (match responses
+ (((response data) rest ...)
+ (set! responses rest)
+ (values response data))
+ ((((? string?) response data) ...)
+ (let ((path (uri-path (request-uri request))))
+ (match (assoc path responses)
+ (#f (values bad-request ""))
+ ((_ response data)
+ (if (eq? 'GET (request-method request))
+ ;; Note: Use 'assoc-remove!' to remove only the first entry
+ ;; with PATH as its key. That way, RESPONSES can contain
+ ;; the same path several times.
+ (let ((rest (assoc-remove! responses path)))
+ (set! responses rest)
+ (values response data))
+ (values bad-request ""))))))))
+
+ (let-values (((socket port) (open-http-server-socket)))
+ (set! %http-real-server-port port)
+ (catch 'quit
+ (lambda ()
+ ;; Let HANDLE refer to '%http-server-port' if needed.
+ (parameterize ((%http-server-port %http-real-server-port))
+ (run-server handle stub-http-server
+ `(#:socket ,socket))))
+ (lambda _
+ (close-port socket)))))
+
+ (with-mutex %http-server-lock
+ (let ((server (make-thread server-body)))
+ (wait-condition-variable %http-server-ready %http-server-lock)
+ ;; Normally SERVER exits automatically once it has received a request.
+ (parameterize ((%http-server-port %http-real-server-port))
+ (thunk)))))
+
+(define-syntax with-http-server
+ (syntax-rules ()
+ ((_ responses+data body ...)
+ (call-with-http-server responses+data (lambda () body ...)))))
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 01/13] cuirass: config: Add %sysconfdir.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-1-romain.garbage@inria.fr
* src/cuirass/config.scm.in (%sysconfdir): New variable.
---
src/cuirass/config.scm.in | 5 +++++
1 file changed, 5 insertions(+)

Toggle diff (17 lines)
diff --git a/src/cuirass/config.scm.in b/src/cuirass/config.scm.in
index 58ab081..f2c1b2a 100644
--- a/src/cuirass/config.scm.in
+++ b/src/cuirass/config.scm.in
@@ -61,3 +61,8 @@
;; Define to 'PREFIX/run' which is a modifiable single-machine data
;; directory.
"@runstatedir@")
+
+(define-public %sysconfdir
+ ;; Define to 'PREFIX/etc' which is a modifiable single-machine data
+ ;; directory.
+ "@sysconfdir@")

base-commit: 520b2fdbd96e953fc2d4b56e78e52a81fc11e2b7
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 06/13] forgejo: Add API communication primitive.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-6-romain.garbage@inria.fr
* src/cuirass/forges/forgejo.scm (forgejo-request, %forgejo-port,
%forgejo-scheme): New variables.
* tests/forgejo.scm: New test for forgejo-request.
---
src/cuirass/forges/forgejo.scm | 74 ++++++++++++++++++++++++++++++++--
tests/forgejo.scm | 18 +++++++++
2 files changed, 89 insertions(+), 3 deletions(-)

Toggle diff (143 lines)
diff --git a/src/cuirass/forges/forgejo.scm b/src/cuirass/forges/forgejo.scm
index 73ab609..b91413d 100644
--- a/src/cuirass/forges/forgejo.scm
+++ b/src/cuirass/forges/forgejo.scm
@@ -1,5 +1,5 @@
;;; forgejo.scm -- Forgejo JSON mappings
-;;; Copyright © 2024 Romain Garbage <romain.garbage@inria.fr>
+;;; Copyright © 2024, 2025 Romain Garbage <romain.garbage@inria.fr>
;;;
;;; This file is part of Cuirass.
;;;
@@ -20,9 +20,19 @@
#:use-module (cuirass specification)
#:use-module (cuirass forges)
#:use-module (json)
+ #:use-module (web client)
#:use-module (web http)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:use-module (guix base64)
#:use-module (guix channels)
+ #:use-module (ice-9 iconv)
#:use-module (ice-9 match)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
#:export (forgejo-pull-request-event-pull-request
forgejo-pull-request-event-action
json->forgejo-pull-request-event
@@ -32,12 +42,18 @@
json->forgejo-pull-request
- forgejo-pull-request->specification))
+ forgejo-pull-request->specification
+
+ ;; Used in tests.
+ forgejo-request
+ %forgejo-port
+ %forgejo-scheme))
;;; Commentary:
;;;
;;; This module implements a subset of the Forgejo Webhook API described at
-;;; <https://forgejo.org/docs/latest/user/webhooks/>.
+;;; <https://forgejo.org/docs/latest/user/webhooks/> and a subset of the REST
+;;; API described at <https://codeberg.org/api/swagger>.
;;;
;;; Code:
@@ -144,3 +160,55 @@
. ,(forgejo-repository-name repository))
(pull-request-target-repository-home-page
. ,(forgejo-repository-home-page repository))))))))
+
+;;; Error types for the Forgejo API.
+(define-condition-type &forgejo-client-error &error
+ forgejo-error?)
+
+(define-condition-type &forgejo-invalid-response-error &forgejo-client-error
+ forgejo-invalid-reponse-error?
+ (headers forgejo-invalid-response-headers))
+
+;;; Parameterize port and scheme for tests.
+(define %forgejo-port
+ (make-parameter #f))
+
+(define %forgejo-scheme
+ (make-parameter 'https))
+
+;;; Helper function for API requests.
+(define* (forgejo-request server endpoint
+ #:key token
+ method
+ (body #f) ; default value in http-request.
+ (headers '()))
+ "Sends an TOKEN authenticated JSON request to SERVER at ENDPOINT using
+METHOD. Returns the body of the response as a Guile object."
+ (let* ((uri (build-uri (%forgejo-scheme)
+ #:host server
+ #:port (%forgejo-port)
+ #:path endpoint))
+ (headers (append
+ headers
+ `((content-type . (application/json))
+ ;; The Auth Basic scheme needs a base64-encoded
+ ;; colon-separated user and token values. Forgejo doesn't
+ ;; seem to care for the user part but the colon seems to
+ ;; be necessary for the token value to get extracted.
+ (authorization . (basic . ,(base64-encode
+ (string->utf8
+ (string-append ":" token))))))))
+ (response response-body (http-request uri
+ #:method method
+ #:headers headers
+ #:body (scm->json-string body)))
+ (charset (match (assoc-ref (response-headers response) 'content-type)
+ (('application/json ('charset . charset))
+ charset)
+ (content-type
+ (raise
+ (condition
+ (&forgejo-invalid-response-error
+ (headers (response-headers response)))))))))
+ (json-string->scm
+ (bytevector->string response-body charset))))
diff --git a/tests/forgejo.scm b/tests/forgejo.scm
index dfb3903..8ffdbcf 100644
--- a/tests/forgejo.scm
+++ b/tests/forgejo.scm
@@ -19,6 +19,7 @@
(use-modules (cuirass forges)
(cuirass forges forgejo)
(cuirass specification)
+ (cuirass tests http)
(cuirass utils)
(cuirass tests common)
(guix channels)
@@ -86,3 +87,20 @@
(pull-request-number . 1)
(pull-request-target-repository-name . project-name)
(pull-request-target-repository-home-page . "https://forgejo.instance.test/base-repo/project-name"))))))
+
+(test-equal "forgejo-request: return value"
+ (json-string->scm default-pull-request-json)
+ (with-http-server `((,(build-response
+ #:code 200
+ #:reason-phrase "OK"
+ #:headers '((content-type . (application/json (charset . "utf-8"))))) ,default-pull-request-json))
+ (let* ((url (string->uri (%local-url)))
+ (hostname (uri-host url))
+ (scheme (uri-scheme url))
+ (port (uri-port url)))
+ (parameterize ((%forge-token-directory "/tmp")
+ (%forgejo-port port)
+ (%forgejo-scheme scheme))
+ (forgejo-request hostname "/"
+ #:token "token"
+ #:method 'GET)))))
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 05/13] tests: Move common module to src/cuirass/tests.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-5-romain.garbage@inria.fr
* src/cuirass/tests/common.scm: New file.
* tests/common.scm: Remove file.
* Makefile.am (nodist_noinst_DATA): Add new module.
* tests/database.scm, tests/forgejo.scm, tests/gitlab.scm, tests/http.scm,
tests/metrics.scm, tests/register.scm, tests/remote.scm: Update module
location.
---
Makefile.am | 3 ++-
{tests => src/cuirass/tests}/common.scm | 2 +-
tests/database.scm | 2 +-
tests/forgejo.scm | 2 +-
tests/gitlab.scm | 2 +-
tests/http.scm | 2 +-
tests/metrics.scm | 2 +-
tests/register.scm | 2 +-
tests/remote.scm | 2 +-
9 files changed, 10 insertions(+), 9 deletions(-)
rename {tests => src/cuirass/tests}/common.scm (99%)

Toggle diff (123 lines)
diff --git a/Makefile.am b/Makefile.am
index e1d2cb6..75b406f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -100,7 +100,8 @@ nodist_scriptsobject_DATA = \
nodist_webobject_DATA = \
$(dist_webmodule_DATA:.scm=.go)
-nodist_noinst_DATA = \
+nodist_noinst_DATA = \
+ src/cuirass/tests/common.scm \
src/cuirass/tests/http.scm
dist_pkgdata_DATA = src/schema.sql
diff --git a/tests/common.scm b/src/cuirass/tests/common.scm
similarity index 99%
rename from tests/common.scm
rename to src/cuirass/tests/common.scm
index 479fef3..3ebb0ad 100644
--- a/tests/common.scm
+++ b/src/cuirass/tests/common.scm
@@ -16,7 +16,7 @@
;;; 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 (tests common)
+(define-module (cuirass tests common)
#:use-module ((cuirass base) #:select (%bridge-socket-file-name))
#:use-module (cuirass database)
#:use-module (cuirass parameters)
diff --git a/tests/database.scm b/tests/database.scm
index 2dcc68f..9dab26e 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -30,7 +30,7 @@
#:select (%gc-root-directory))
(cuirass utils)
((cuirass logging) #:select (current-logging-level))
- (tests common)
+ (cuirass tests common)
(guix channels)
((guix store) #:select (open-connection add-text-to-store))
((guix build utils)
diff --git a/tests/forgejo.scm b/tests/forgejo.scm
index 10f183a..dfb3903 100644
--- a/tests/forgejo.scm
+++ b/tests/forgejo.scm
@@ -20,7 +20,7 @@
(cuirass forges forgejo)
(cuirass specification)
(cuirass utils)
- (tests common)
+ (cuirass tests common)
(guix channels)
(json)
(fibers)
diff --git a/tests/gitlab.scm b/tests/gitlab.scm
index 7d24a6a..1e29f73 100644
--- a/tests/gitlab.scm
+++ b/tests/gitlab.scm
@@ -20,7 +20,7 @@
(cuirass forges gitlab)
(cuirass specification)
(cuirass utils)
- (tests common)
+ (cuirass tests common)
(guix channels)
(json)
(fibers)
diff --git a/tests/http.scm b/tests/http.scm
index a57a4ab..bee02c9 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -27,7 +27,7 @@
(cuirass forges gitlab)
(cuirass specification)
(cuirass utils)
- (tests common)
+ (cuirass tests common)
(guix channels)
(json)
(fibers)
diff --git a/tests/metrics.scm b/tests/metrics.scm
index 195b043..759502a 100644
--- a/tests/metrics.scm
+++ b/tests/metrics.scm
@@ -20,7 +20,7 @@
(use-modules (cuirass database)
(cuirass metrics)
(cuirass utils)
- (tests common)
+ (cuirass tests common)
((guix build utils) #:select (call-with-temporary-output-file))
(squee)
(srfi srfi-64))
diff --git a/tests/register.scm b/tests/register.scm
index db0c73c..e4a2ade 100644
--- a/tests/register.scm
+++ b/tests/register.scm
@@ -20,7 +20,7 @@
(cuirass database)
(cuirass specification)
(guix channels)
- (tests common)
+ (cuirass tests common)
(ice-9 match)
(srfi srfi-64))
diff --git a/tests/remote.scm b/tests/remote.scm
index bfc1add..864579c 100644
--- a/tests/remote.scm
+++ b/tests/remote.scm
@@ -41,7 +41,7 @@
(guix packages)
((guix store) #:hide (build))
((guix utils) #:select (%current-system))
- (tests common)
+ (cuirass tests common)
(fibers)
(squee)
(simple-zmq)
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 08/13] forgejo: Extend specification properties content.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-8-romain.garbage@inria.fr
* src/cuirass/forges/forgejo.scm:
(<forgejo-owner>): New JSON mapping.
(<forgejo-repository>): Add owner and namespace fields.
(<forgejo-pull-request>): Add body field.
(forgejo-pull-request->specification): Add
PULL-REQUEST-TARGET-REPOSITORY-OWNER and PULL-REQUEST-TARGET-NAMESPACE properties.
* tests/forgejo.scm (default-pull-request-json): Add missing fields.
* tests/http.scm (forgejo-pull-request-json-open): Add missing fields.
(forgejo-pull-request-json-close): Add missing fields.
---
src/cuirass/forges/forgejo.scm | 25 ++++++++++++++++++++-----
tests/forgejo.scm | 10 ++++++++++
tests/http.scm | 14 ++++++++++++++
3 files changed, 44 insertions(+), 5 deletions(-)

Toggle diff (141 lines)
diff --git a/src/cuirass/forges/forgejo.scm b/src/cuirass/forges/forgejo.scm
index 9cd846f..3e7f375 100644
--- a/src/cuirass/forges/forgejo.scm
+++ b/src/cuirass/forges/forgejo.scm
@@ -64,14 +64,23 @@
;; generating requests during tests.
(declare-opaque-header! "X-Forgejo-Event")
+(define-json-mapping <forgejo-owner>
+ make-forgejo-owner
+ forgejo-owner?
+ json->forgejo-owner
+ (login forgejo-owner-login))
+
(define-json-mapping <forgejo-repository>
make-forgejo-repository
forgejo-repository?
json->forgejo-repository
- (name forgejo-repository-name "name"
- string->symbol)
- (url forgejo-repository-url "clone_url")
- (home-page forgejo-repository-home-page "html_url"))
+ (name forgejo-repository-name "name"
+ string->symbol)
+ (namespace forgejo-repository-namespace "full_name")
+ (url forgejo-repository-url "clone_url")
+ (home-page forgejo-repository-home-page "html_url")
+ (owner forgejo-repository-owner "owner"
+ json->forgejo-owner))
;; This maps to the top level JSON object.
(define-json-mapping <forgejo-pull-request-event>
@@ -92,7 +101,8 @@
(base forgejo-pull-request-base "base"
json->forgejo-repository-reference)
(head forgejo-pull-request-head "head"
- json->forgejo-repository-reference))
+ json->forgejo-repository-reference)
+ (body forgejo-pull-request-body))
;; This mapping is used to define various JSON objects such as "base" or
;; "head".
@@ -161,6 +171,11 @@
(pull-request-number . ,(forgejo-pull-request-number pull-request))
(pull-request-target-repository-name
. ,(forgejo-repository-name repository))
+ (pull-request-target-repository-owner
+ . ,(forgejo-owner-login
+ (forgejo-repository-owner repository)))
+ (pull-request-target-namespace
+ . ,(forgejo-repository-namespace repository))
(pull-request-target-repository-home-page
. ,(forgejo-repository-home-page repository))))))))
diff --git a/tests/forgejo.scm b/tests/forgejo.scm
index 2528f5b..0a388ba 100644
--- a/tests/forgejo.scm
+++ b/tests/forgejo.scm
@@ -48,7 +48,11 @@
\"ref\": \"base-branch\",
\"sha\": \"666af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
\"repo\": {
+ \"owner\": {
+ \"login\": \"project-owner\"
+ },
\"name\": \"project-name\",
+ \"full_name\": \"base-repo/project-name\",
\"clone_url\": \"https://forgejo.instance.test/base-repo/project-name.git\",
\"html_url\": \"https://forgejo.instance.test/base-repo/project-name\"
}
@@ -58,7 +62,11 @@
\"ref\": \"test-branch\",
\"sha\": \"582af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
\"repo\": {
+ \"owner\": {
+ \"login\": \"fork-owner\"
+ },
\"name\": \"fork-name\",
+ \"full_name\": \"fork-owner/fork-name\",
\"clone_url\": \"https://forgejo.instance.test/source-repo/fork-name.git\",
\"html_url\": \"https://forgejo.instance.test/source-repo/fork-name\"
}
@@ -87,6 +95,8 @@
(pull-request-url . "https://forgejo.instance.test/base-repo/pulls/1")
(pull-request-number . 1)
(pull-request-target-repository-name . project-name)
+ (pull-request-target-repository-owner . "project-owner")
+ (pull-request-target-namespace . "base-repo/project-name")
(pull-request-target-repository-home-page . "https://forgejo.instance.test/base-repo/project-name"))))))
(test-equal "forgejo-request: return value"
diff --git a/tests/http.scm b/tests/http.scm
index bee02c9..74472ad 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -159,7 +159,11 @@
\"ref\": \"base-branch\",
\"sha\": \"666af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
\"repo\": {
+ \"owner\": {
+ \"login\": \"project-owner\"
+ },
\"name\": \"project-name\",
+ \"full_name\": \"base-repo/project-name\",
\"clone_url\": \"https://forgejo.instance.test/base-repo/project-name.git\",
\"html_url\": \"https://forgejo.instance.test/base-repo/project-name\"
}
@@ -169,6 +173,9 @@
\"ref\": \"test-branch\",
\"sha\": \"582af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
\"repo\": {
+ \"owner\": {
+ \"login\": \"fork-owner\"
+ },
\"name\": \"fork-name\",
\"clone_url\": \"https://forgejo.instance.test/source-repo/fork-name.git\",
\"html_url\": \"https://forgejo.instance.test/source-repo/fork-name\"
@@ -188,7 +195,11 @@
\"ref\": \"base-branch\",
\"sha\": \"666af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
\"repo\": {
+ \"owner\": {
+ \"login\": \"project-owner\"
+ },
\"name\": \"project-name\",
+ \"full_name\": \"base-repo/project-name\",
\"clone_url\": \"https://forgejo.instance.test/base-repo/project-name.git\"
}
},
@@ -197,6 +208,9 @@
\"ref\": \"test-branch\",
\"sha\": \"582af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
\"repo\": {
+ \"owner\": {
+ \"login\": \"fork-owner\"
+ },
\"name\": \"fork-name\",
\"clone_url\": \"https://forgejo.instance.test/source-repo/fork-name.git\"
}
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 13/13] base: Add support for forge notification in jobset-monitor.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-13-romain.garbage@inria.fr
* src/cuirass/base.scm (jobset-monitor, spawn-jobset-monitor): Add support for forge notification.
(jobset-registry): Transmit the communication channel for event-log to jobset-monitors.
---
src/cuirass/base.scm | 19 +++++++++++++++++++
1 file changed, 19 insertions(+)

Toggle diff (60 lines)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index c3a0fb6..d62960e 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -25,6 +25,7 @@
#:use-module (fibers channels)
#:use-module (cuirass logging)
#:use-module (cuirass database)
+ #:use-module (cuirass forges notification)
#:autoload (cuirass metrics) (db-remove-specification-metrics)
#:use-module (cuirass remote)
#:use-module (cuirass specification)
@@ -123,6 +124,10 @@
;;; such as evaluation triggers that can come, for example, from the
;;; /jobset/NAME/hook/evaluate HTTP endpoint.
;;;
+;;; - Each jobset might also be associated with a "forge notifier", started by
+;;; the "monitor": when applicable, it is responsible for communicating with
+;;; external forges using the correspondent API.
+;;;
;;; - The "jobset" registry is a directory that maps jobset names to their
;;; monitor.
;;;
@@ -874,6 +879,14 @@ notification subscriptions."
update-service evaluator event-log)
(define name (specification-name spec))
+ (define forge-notifier (and (assoc-ref (specification-properties spec)
+ 'forge-type)
+ (spawn-forge-notification-service spec)))
+
+ (when forge-notifier
+ (put-message event-log
+ `(subscribe ,forge-notifier)))
+
(lambda ()
(log-info "starting monitor for spec '~a'" name)
(let loop ((spec spec)
@@ -954,6 +967,9 @@ notification subscriptions."
(loop spec last-updates))
('terminate
(log-info "terminating monitor of jobset '~a'" name)
+ (when forge-notifier
+ (put-message event-log
+ `(unsubscribe ,forge-notifier)))
#t)
(message
(log-warning "jobset '~a' got bogus message: ~s"
@@ -976,6 +992,9 @@ notification subscriptions."
(loop spec last-updates))
('terminate
(log-info "terminating monitor of inactive jobset '~a'" name)
+ (when forge-notifier
+ (put-message event-log
+ `(unsubscribe ,forge-notifier)))
#t)
(message
(log-warning "inactive jobset '~a' got unexpected message: ~s"
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 12/13] forgejo: Add notification handling.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-12-romain.garbage@inria.fr
* src/cuirass/forges/forgejo.scm (forgejo-handle-notification): New variable.
* tests/forgejo.scm: Add test for forgejo-handle-notification.
* src/cuirass/forges/notification.scm (%forge-notification-handlers): Add
handler for forgejo forge type.
---
src/cuirass/forges/forgejo.scm | 74 ++++++++++++++++++++++++++++-
src/cuirass/forges/notification.scm | 2 +-
tests/forgejo.scm | 18 +++++++
3 files changed, 92 insertions(+), 2 deletions(-)

Toggle diff (145 lines)
diff --git a/src/cuirass/forges/forgejo.scm b/src/cuirass/forges/forgejo.scm
index f84685b..5d1fbb1 100644
--- a/src/cuirass/forges/forgejo.scm
+++ b/src/cuirass/forges/forgejo.scm
@@ -17,8 +17,10 @@
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
(define-module (cuirass forges forgejo)
- #:use-module (cuirass specification)
+ #:use-module (cuirass database)
#:use-module (cuirass forges)
+ #:use-module (cuirass parameters)
+ #:use-module (cuirass specification)
#:use-module (json)
#:use-module (web client)
#:use-module (web http)
@@ -29,6 +31,7 @@
#:use-module (ice-9 iconv)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
@@ -47,6 +50,8 @@
update-forgejo-pull-request
update-forgejo-pull-request-from-spec
+ forgejo-handle-notification
+
;; Used in tests.
forgejo-request
%forgejo-port
@@ -334,3 +339,70 @@ CONTENT, a string. Returns the content of the updated pull-request body."
#:repository repository
#:pull-request-index pull-request-index
#:content content)))
+
+;;;
+;;; Forgejo specific handler of the forge-notification-service agent.
+;;;
+
+(define* (forgejo-handle-notification spec
+ #:key
+ (jobset-created #f)
+ (evaluation-started #f)
+ (evaluation-succeeded #f)
+ (evaluation-failed #f)
+ (build-results #f))
+ "Send notifications to a Forgejo instance. SPEC is a specification record,
+JOBSET-CREATED is a boolean, EVALUATION-STARTED, EVALUATION-SUCCEEDED and
+EVALUATION-FAILED are numbers and BUILD-RESULTS is a list of build records."
+ (let* ((name (specification-name spec))
+ (message (cond
+ (jobset-created
+ (format #f
+ "> Created Cuirass jobset [~a](~a/jobset/~a)."
+ name %cuirass-url name))
+ (evaluation-started
+ (format #f
+ "> Started evaluation [~a](~a/eval/~a) of Cuirass jobset [~a](~a/jobset/~a)."
+ evaluation-started %cuirass-url evaluation-started
+ name %cuirass-url name))
+ (evaluation-succeeded
+ (format #f
+ "> Finished evaluation [~a](~a/eval/~a) of Cuirass jobset [~a](~a/jobset/~a)."
+ evaluation-succeeded %cuirass-url evaluation-succeeded
+ name %cuirass-url name))
+ (evaluation-failed
+ (format #f
+ "> Evaluation [~a](~a/eval/~a) of Cuirass jobset [~a](~a/jobset/~a) failed."
+ evaluation-failed %cuirass-url evaluation-failed
+ name %cuirass-url name))
+ (build-results
+ (let* ((evaluation-id (max (filter-map build-evaluation-id
+ build-results)))
+ (header
+ (format #f "> Results for evaluation [~a](~a/eval/~a) of Cuirass jobset [~a](~a/jobset/~a):~%"
+ evaluation-id %cuirass-url evaluation-id
+ name %cuirass-url name))
+ (succeeded-builds (filter-map (lambda (build)
+ (and (eq? 0 (build-current-status build))
+ (build-nix-name build)))
+ build-results))
+ (failed-builds (filter-map (lambda (build)
+ (and (build-failure?
+ (build-current-status build))
+ (build-nix-name build)))
+ build-results))
+ (successes (if (null? succeeded-builds)
+ ""
+ (format #f "> Successfully build ~a package(s): ~a~%"
+ (length succeeded-builds)
+ (string-join succeeded-builds ", "))))
+ (failures (if (null? failed-builds)
+ ""
+ (format #f "> Failed build ~a package(s): ~a~%"
+ (length failed-builds)
+ (string-join failed-builds ", ")))))
+ (string-append header successes failures)))
+ (#t #f))))
+ ;; XXX: Raise an error when no message has been generated?
+ (when message
+ (update-forgejo-pull-request-from-spec spec message))))
diff --git a/src/cuirass/forges/notification.scm b/src/cuirass/forges/notification.scm
index ca7ed7b..0d1842f 100644
--- a/src/cuirass/forges/notification.scm
+++ b/src/cuirass/forges/notification.scm
@@ -61,7 +61,7 @@
;; - EVALUATION-FAILED, a number (evaluation-id)
;; - BUILD-RESULTS, a list of BUILD records
(define %forge-notification-handlers
- '())
+ `((forgejo . ,forgejo-handle-notification)))
;; 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
diff --git a/tests/forgejo.scm b/tests/forgejo.scm
index 8003c7d..f7c3097 100644
--- a/tests/forgejo.scm
+++ b/tests/forgejo.scm
@@ -211,3 +211,21 @@
#:repository "repository"
#:pull-request-index 1
#:content "New content."))))))
+
+(test-equal "forgejo-handle-notification"
+ #f
+ (let ((default-response
+ (build-response
+ #:code 200
+ #:reason-phrase "OK"
+ #:headers '((content-type . (application/json (charset . "utf-8")))))))
+ (with-http-server `((,default-response ,default-pull-request-json)
+ (,default-response ,updated-body-pull-request-json))
+ (let* ((url (string->uri (%local-url)))
+ (hostname (uri-host url))
+ (scheme (uri-scheme url))
+ (port (uri-port url)))
+ (parameterize ((%forge-token-directory "/tmp")
+ (%forgejo-port port)
+ (%forgejo-scheme scheme))
+ (forgejo-handle-notification ))))))
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 09/13] forgejo: Add pull request update procedures.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-9-romain.garbage@inria.fr
* src/cuirass/forges/forgejo.scm (update-forgejo-pull-request, update-forgejo-pull-request-from-spec): New variables.
* tests/forgejo.scm: Add tests for update-forgejo-pull-request.
---
src/cuirass/forges/forgejo.scm | 56 ++++++++++++++++++++++
tests/forgejo.scm | 85 ++++++++++++++++++++++++++++++++++
2 files changed, 141 insertions(+)

Toggle diff (173 lines)
diff --git a/src/cuirass/forges/forgejo.scm b/src/cuirass/forges/forgejo.scm
index 3e7f375..f84685b 100644
--- a/src/cuirass/forges/forgejo.scm
+++ b/src/cuirass/forges/forgejo.scm
@@ -44,6 +44,9 @@
forgejo-pull-request->specification
+ update-forgejo-pull-request
+ update-forgejo-pull-request-from-spec
+
;; Used in tests.
forgejo-request
%forgejo-port
@@ -278,3 +281,56 @@ JSON. Returns the content of the updated pull-request."
#:token token
#:method 'PATCH
#:body changes))))
+
+;;; Extra helper procedures using the API.
+(define* (update-forgejo-pull-request server token #:key owner
+ repository
+ pull-request-index
+ content)
+ "Update the content of the pull request PULL-REQUEST-INDEX with CONTENT, a
+string. Returns the content of the updated pull-request body."
+ (let* ((previous-body (forgejo-pull-request-body
+ (forgejo-api-pull-request-get server token
+ #:owner owner
+ #:repository repository
+ #:pull-request-index pull-request-index)))
+ (new-body (string-append previous-body "\n" content))
+ (updated-body (forgejo-pull-request-body
+ (forgejo-api-pull-request-update server token
+ #:owner owner
+ #:repository repository
+ #:pull-request-index pull-request-index
+ #:changes `((body . ,new-body))))))
+ ;; Ensure new content is the same as expected content.
+ (unless (string=? updated-body new-body)
+ (raise
+ (condition
+ (&forgejo-api-error
+ (message (format #f
+ "Content not modified as expected.~%Expected content:~%~a~%Actual content:~%~a~%"
+ new-body
+ updated-body))))))))
+
+(define (update-forgejo-pull-request-from-spec spec content)
+ "Given SPEC, a specification that was built using
+FORGEJO-PULL-REQUEST->SPECIFICATION, update the pull-request body with
+CONTENT, a string. Returns the content of the updated pull-request body."
+ (let* ((properties (specification-properties spec))
+ (url (string->uri
+ (assoc-ref properties
+ 'pull-request-url)))
+ (server (uri-host url))
+ (token (forge-get-token server
+ (assoc-ref properties
+ 'pull-request-target-namespace)))
+ (owner (assoc-ref properties
+ 'pull-request-target-repository-owner))
+ (repository (assoc-ref properties
+ 'pull-request-target-repository-name))
+ (pull-request-index (assoc-ref properties
+ 'pull-request-number)))
+ (update-forgejo-pull-request server token
+ #:owner owner
+ #:repository repository
+ #:pull-request-index pull-request-index
+ #:content content)))
diff --git a/tests/forgejo.scm b/tests/forgejo.scm
index 0a388ba..8003c7d 100644
--- a/tests/forgejo.scm
+++ b/tests/forgejo.scm
@@ -43,6 +43,7 @@
\"number\": 1,
\"state\": \"open\",
\"url\": \"https://forgejo.instance.test/base-repo/pulls/1\",
+ \"body\": \"Some content.\",
\"base\": {
\"label\": \"base-label\",
\"ref\": \"base-branch\",
@@ -126,3 +127,87 @@
(api-build-endpoint "pulls/1")
;; Assert false since it should return an error.
#f))
+
+(define updated-body-pull-request-json
+ "{
+ \"action\": \"opened\",
+ \"pull_request\": {
+ \"number\": 1,
+ \"state\": \"open\",
+ \"url\": \"https://forgejo.instance.test/base-repo/pulls/1\",
+ \"body\": \"Some content.\\nNew content.\",
+ \"base\": {
+ \"label\": \"base-label\",
+ \"ref\": \"base-branch\",
+ \"sha\": \"666af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
+ \"repo\": {
+ \"owner\": {
+ \"login\": \"project-owner\"
+ },
+ \"name\": \"project-name\",
+ \"full_name\": \"base-repo/project-name\",
+ \"clone_url\": \"https://forgejo.instance.test/base-repo/project-name.git\",
+ \"html_url\": \"https://forgejo.instance.test/base-repo/project-name\"
+ }
+ },
+ \"head\": {
+ \"label\": \"test-label\",
+ \"ref\": \"test-branch\",
+ \"sha\": \"582af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
+ \"repo\": {
+ \"owner\": {
+ \"login\": \"pr-owner\"
+ },
+ \"name\": \"fork-name\",
+ \"full_name\": \"source-repo/fork-name\",
+ \"clone_url\": \"https://forgejo.instance.test/source-repo/fork-name.git\",
+ \"html_url\": \"https://forgejo.instance.test/source-repo/fork-name\"
+ }
+ }
+ }
+ }")
+
+(test-assert "update-forgejo-pull-request: content not updated by server"
+ (let ((default-response
+ (build-response
+ #:code 200
+ #:reason-phrase "OK"
+ #:headers '((content-type . (application/json (charset . "utf-8")))))))
+ (with-http-server `((,default-response ,default-pull-request-json)
+ (,default-response ,default-pull-request-json))
+ (let* ((url (string->uri (%local-url)))
+ (hostname (uri-host url))
+ (scheme (uri-scheme url))
+ (port (uri-port url)))
+ (parameterize ((%forge-token-directory "/tmp")
+ (%forgejo-port port)
+ (%forgejo-scheme scheme))
+ (guard (c (#t
+ c))
+ (update-forgejo-pull-request hostname "token"
+ #:owner "owner"
+ #:repository "repository"
+ #:pull-request-index 1
+ #:content "New content.")
+ #f))))))
+
+(test-assert "update-forgejo-pull-request: content properly updated by server"
+ (let ((default-response
+ (build-response
+ #:code 200
+ #:reason-phrase "OK"
+ #:headers '((content-type . (application/json (charset . "utf-8")))))))
+ (with-http-server `((,default-response ,default-pull-request-json)
+ (,default-response ,updated-body-pull-request-json))
+ (let* ((url (string->uri (%local-url)))
+ (hostname (uri-host url))
+ (scheme (uri-scheme url))
+ (port (uri-port url)))
+ (parameterize ((%forge-token-directory "/tmp")
+ (%forgejo-port port)
+ (%forgejo-scheme scheme))
+ (update-forgejo-pull-request hostname "token"
+ #:owner "owner"
+ #:repository "repository"
+ #:pull-request-index 1
+ #:content "New content."))))))
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 07/13] forgejo: Add pull request API manipulation procedures.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-7-romain.garbage@inria.fr
* src/cuirass/forges/forgejo.scm: (%forgejo-api-base-path, api-build-endpoint,
&forgejo-api-error, forgejo-api-pull-request-get,
forgejo-api-pull-request-update): New variables.
* tests/forgejo.scm: Add tests for api-build-endpoint.
---
src/cuirass/forges/forgejo.scm | 53 +++++++++++++++++++++++++++++++++-
tests/forgejo.scm | 12 ++++++++
2 files changed, 64 insertions(+), 1 deletion(-)

Toggle diff (104 lines)
diff --git a/src/cuirass/forges/forgejo.scm b/src/cuirass/forges/forgejo.scm
index b91413d..9cd846f 100644
--- a/src/cuirass/forges/forgejo.scm
+++ b/src/cuirass/forges/forgejo.scm
@@ -47,7 +47,10 @@
;; Used in tests.
forgejo-request
%forgejo-port
- %forgejo-scheme))
+ %forgejo-scheme
+ api-build-endpoint
+ forgejo-api-pull-request-get
+ forgejo-api-pull-request-update))
;;; Commentary:
;;;
@@ -169,6 +172,10 @@
forgejo-invalid-reponse-error?
(headers forgejo-invalid-response-headers))
+(define-condition-type &forgejo-api-error &forgejo-client-error
+ forgejo-api-error?
+ (message forgejo-api-message))
+
;;; Parameterize port and scheme for tests.
(define %forgejo-port
(make-parameter #f))
@@ -212,3 +219,47 @@ METHOD. Returns the body of the response as a Guile object."
(headers (response-headers response)))))))))
(json-string->scm
(bytevector->string response-body charset))))
+
+;;;
+;;; REST API
+;;;
+(define %forgejo-api-base-path "/api/v1")
+
+;; PATHs are defined e.g. here: <https://codeberg.org/api/swagger>.
+(define (api-build-endpoint path)
+ "Returns an API endpoint built from PATH as defined in the documentation."
+ (when (not (string-prefix? "/" path))
+ (raise
+ (condition
+ (&forgejo-api-error
+ (message "Provided path should start with /.")))))
+ (string-append %forgejo-api-base-path path))
+
+(define* (forgejo-api-pull-request-get server token #:key owner
+ repository
+ pull-request-index)
+ "Returns the content of a pull request as a FORGEJO-PULL-REQUEST record."
+ (forgejo-pull-request-event-pull-request
+ (json->forgejo-pull-request-event
+ (forgejo-request server
+ (api-build-endpoint
+ (format #f "/repos/~a/~a/pulls/~a"
+ owner repository pull-request-index))
+ #:token token
+ #:method 'GET))))
+
+(define* (forgejo-api-pull-request-update server token #:key owner
+ repository
+ pull-request-index
+ changes)
+ "Updates the pull request with CHANGES, Guile code that can be converted to
+JSON. Returns the content of the updated pull-request."
+ (forgejo-pull-request-event-pull-request
+ (json->forgejo-pull-request-event
+ (forgejo-request server
+ (api-build-endpoint
+ (format #f "/repos/~a/~a/pulls/~a"
+ owner repository pull-request-index))
+ #:token token
+ #:method 'PATCH
+ #:body changes))))
diff --git a/tests/forgejo.scm b/tests/forgejo.scm
index 8ffdbcf..2528f5b 100644
--- a/tests/forgejo.scm
+++ b/tests/forgejo.scm
@@ -31,6 +31,7 @@
(web response)
(rnrs bytevectors)
(srfi srfi-1)
+ (srfi srfi-34)
(srfi srfi-64)
(ice-9 threads)
(ice-9 match))
@@ -104,3 +105,14 @@
(forgejo-request hostname "/"
#:token "token"
#:method 'GET)))))
+
+(test-equal "api-build-endpoint: valid path"
+ "/api/v1/pulls/1"
+ (api-build-endpoint "/pulls/1"))
+
+(test-assert "api-build-endpoint: invalid path"
+ (guard (c (#t
+ c))
+ (api-build-endpoint "pulls/1")
+ ;; Assert false since it should return an error.
+ #f))
--
2.48.1
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 11/13] forges: notification: Add forge notification actor.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-11-romain.garbage@inria.fr
* 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

Toggle diff (333 lines)
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@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@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
Romain GARBAGE wrote 25 hours ago
[PATCH Cuirass 10/13] database: Export build-failure?.
(address . 76938@debbugs.gnu.org)
20250311103442.3074-10-romain.garbage@inria.fr
* src/cuirass/database.scm: Export build-failure?.
---
src/cuirass/database.scm | 1 +
1 file changed, 1 insertion(+)

Toggle diff (14 lines)
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 4e4f233..6e0923d 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -97,6 +97,7 @@
build-worker
build-products
build-dependencies/id
+ build-failure?
build-product
build-product-id
--
2.48.1
?
Your comment

Commenting via the web interface is currently disabled.

To comment on this conversation send an email to 76938@debbugs.gnu.org

To respond to this issue using the mumi CLI, first switch to it
mumi current 76938
Then, you may apply the latest patchset in this issue (with sign off)
mumi am -- -s
Or, compose a reply to this issue
mumi compose
Or, send patches to this issue
mumi send-email *.patch
You may also tag this issue. See list of standard tags. For example, to set the confirmed and easy tags
mumi command -t +confirmed -t +easy
Or, remove the moreinfo tag and set the help tag
mumi command -t -moreinfo -t +help