From: Romain GARBAGE <romain.garbage@inria.fr>
To: guix-patches@gnu.org
Cc: ludovic.courtes@inria.fr, Romain GARBAGE <romain.garbage@inria.fr>
Subject: [PATCH Cuirass 00/13] Forges notification support.
Date: Tue, 11 Mar 2025 11:29:21 +0100
| Package | Source(s) | Maintainer(s) | |
|---|---|---|---|
| guix-patches | PTS Buildd Popcon |
Report forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:34:01 GMT) (full text, mbox, link).
Acknowledgement sent
to Romain GARBAGE <romain.garbage@inria.fr>:
New bug report received and forwarded. Copy sent to guix-patches@gnu.org.
(Tue, 11 Mar 2025 10:34:02 GMT) (full text, mbox, link).
Message #5 received at submit@debbugs.gnu.org (full text, mbox, reply):
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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:02 GMT) (full text, mbox, link).
Message #8 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* src/cuirass/forges.scm (%forge-token-directory, forge-get-token): New variables.
---
src/cuirass/forges.scm | 47 ++++++++++++++++++++++++++++++++++++++++--
1 file changed, 45 insertions(+), 2 deletions(-)
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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:02 GMT) (full text, mbox, link).
Message #11 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* tests/forgejo.scm : Explicit test name.
---
tests/forgejo.scm | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:03 GMT) (full text, mbox, link).
Message #14 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* 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 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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:03 GMT) (full text, mbox, link).
Message #17 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* src/cuirass/config.scm.in (%sysconfdir): New variable. --- src/cuirass/config.scm.in | 5 +++++ 1 file changed, 5 insertions(+) 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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:04 GMT) (full text, mbox, link).
Message #20 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* 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(-)
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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:04 GMT) (full text, mbox, link).
Message #23 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* 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%)
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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:05 GMT) (full text, mbox, link).
Message #26 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* 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(-)
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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:05 GMT) (full text, mbox, link).
Message #29 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* 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(+)
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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:05 GMT) (full text, mbox, link).
Message #32 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* 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(-)
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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:06 GMT) (full text, mbox, link).
Message #35 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* 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(+)
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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:06 GMT) (full text, mbox, link).
Message #38 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* 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(-)
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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:07 GMT) (full text, mbox, link).
Message #41 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* 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@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
Information forwarded
to guix-patches@gnu.org:
bug#76938; Package guix-patches.
(Tue, 11 Mar 2025 10:36:07 GMT) (full text, mbox, link).
Message #44 received at 76938@debbugs.gnu.org (full text, mbox, reply):
* src/cuirass/database.scm: Export build-failure?.
---
src/cuirass/database.scm | 1 +
1 file changed, 1 insertion(+)
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
Reply sent
to Ludovic Courtès <ludo@gnu.org>:
You have taken responsibility.
(Mon, 17 Mar 2025 14:37:05 GMT) (full text, mbox, link).
Notification sent
to Romain GARBAGE <romain.garbage@inria.fr>:
bug acknowledged by developer.
(Mon, 17 Mar 2025 14:37:06 GMT) (full text, mbox, link).
Message #49 received at 76938-done@debbugs.gnu.org (full text, mbox, reply):
Hello, Pushed! 94aacca * base: Add support for forge notification in jobset-monitor. 2ebde98 * forgejo: Add notification handling. ec3d684 * forges: notification: Add forge notification actor. 7b0c166 * database: Export build-failure?. a5f9ec2 * forgejo: Add pull request update procedures. 57e2ff1 * forgejo: Extend specification properties content. d3ea887 * forgejo: Add pull request API manipulation procedures. 9c25999 * forgejo: Add API communication primitive. 389122a * tests: Move common module to src/cuirass/tests. a3360e9 * cuirass: tests: Add mock HTTP server for tests. 8b57085 * tests: forgejo: Explicit test name. ba0c264 * forges: Add support for token storage. ef8265d * cuirass: config: Add %sysconfdir. \o/ Thanks, Ludo’.
bug archived.
Request was from Debbugs Internal Request <help-debbugs@gnu.org>
to internal_control@debbugs.gnu.org.
(Tue, 15 Apr 2025 11:24:10 GMT) (full text, mbox, link).
Send a report that this bug log contains spam.
Debbugs is free software and licensed under the terms of the GNU Public License version 2. The current version can be obtained from https://bugs.debian.org/debbugs-source/.
Copyright © 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson, 2005-2017 Don Armstrong, and many other contributors.