unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
* [bug#74769] [PATCH Cuirass 0/4] Forgejo event support
@ 2024-12-10 16:01 Romain GARBAGE
  2024-12-10 16:09 ` [bug#74769] [PATCH Cuirass 1/4] tests: Move procedure definition Romain GARBAGE
  0 siblings, 1 reply; 5+ messages in thread
From: Romain GARBAGE @ 2024-12-10 16:01 UTC (permalink / raw)
  To: 74769; +Cc: ludovic.courtes, Romain GARBAGE

This patch series adds support for Forgejo pull request events in
Cuirass, as generated using the webhooks mechanism.

The first patch refactors code to make it accessible from different test
modules.
The second patch adds the necessary record type definitions to parse the
JSON data sent by Forgejo.
The third patch improves Gitlab integration related http tests
readability.
The fourth patch adds Forgejo integration to Cuirass' web service.

Romain GARBAGE (4):
  tests: Move procedure definition.
  forgejo: Add module for Forgejo JSON objects definition.
  tests: Explicit Gitlab endpoint related variables.
  http: Add admin/forgejo/event.

 Makefile.am             |   2 +
 doc/cuirass.texi        |  38 ++++++++++--
 src/cuirass/forgejo.scm | 133 ++++++++++++++++++++++++++++++++++++++++
 src/cuirass/http.scm    |  62 +++++++++++++++++++
 tests/common.scm        |  30 ++++++++-
 tests/forgejo.scm       |  79 ++++++++++++++++++++++++
 tests/gitlab.scm        |  24 --------
 tests/http.scm          | 114 ++++++++++++++++++++++++++++++----
 8 files changed, 440 insertions(+), 42 deletions(-)
 create mode 100644 src/cuirass/forgejo.scm
 create mode 100644 tests/forgejo.scm


base-commit: e96f0887923d4d1cd4e35073fcffdb978d7e1e10
-- 
2.46.0





^ permalink raw reply	[flat|nested] 5+ messages in thread

* [bug#74769] [PATCH Cuirass 1/4] tests: Move procedure definition.
  2024-12-10 16:01 [bug#74769] [PATCH Cuirass 0/4] Forgejo event support Romain GARBAGE
@ 2024-12-10 16:09 ` Romain GARBAGE
  2024-12-10 16:09   ` [bug#74769] [PATCH Cuirass 2/4] forgejo: Add module for Forgejo JSON objects definition Romain GARBAGE
                     ` (2 more replies)
  0 siblings, 3 replies; 5+ messages in thread
From: Romain GARBAGE @ 2024-12-10 16:09 UTC (permalink / raw)
  To: 74769; +Cc: ludovic.courtes, Romain GARBAGE

* tests/common.scm (specifications-equal?): New variable.
* tests/gitlab.scm (specifications-equal?): Remove variable.
---
 tests/common.scm | 30 +++++++++++++++++++++++++++++-
 tests/gitlab.scm | 24 ------------------------
 2 files changed, 29 insertions(+), 25 deletions(-)

diff --git a/tests/common.scm b/tests/common.scm
index a807498..5054ea0 100644
--- a/tests/common.scm
+++ b/tests/common.scm
@@ -20,7 +20,9 @@
   #:use-module ((cuirass base) #:select (%bridge-socket-file-name))
   #:use-module (cuirass database)
   #:use-module (cuirass parameters)
+  #:use-module (cuirass specification)
   #:use-module (cuirass utils)
+  #:use-module (guix channels)
   #:use-module ((fibers scheduler) #:select (current-scheduler))
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
@@ -28,7 +30,8 @@
             retry
             test-init-db!
             with-guix-daemon
-            wait-for-bridge))
+            wait-for-bridge
+            specifications-equal?))
 
 (define %db
   (make-parameter #f))
@@ -121,3 +124,28 @@ Return the socket on success and #f on failure."
                         (sockaddr:path address)
                         (strerror (system-error-errno args)))
                 #f)))))))
+
+(define (specifications-equal? spec1 spec2)
+  "Return true if SPEC2 and SPEC2 are equivalent, false otherwise."
+  (and (eq? (specification-name spec1)
+            (specification-name spec2))
+       (equal? (specification-build spec1)
+               (specification-build spec2))
+       (= (specification-priority spec1)
+          (specification-priority spec2))
+       (= (specification-period spec1)
+          (specification-period spec2))
+       (equal? (specification-systems spec1)
+               (specification-systems spec2))
+       (equal? (map channel-name
+                    (specification-channels spec1))
+               (map channel-name
+                    (specification-channels spec2)))
+       (equal? (map channel-url
+                    (specification-channels spec1))
+               (map channel-url
+                    (specification-channels spec2)))
+       (equal? (map channel-branch
+                    (specification-channels spec1))
+               (map channel-branch
+                    (specification-channels spec2)))))
diff --git a/tests/gitlab.scm b/tests/gitlab.scm
index ca6cad5..adf94cc 100644
--- a/tests/gitlab.scm
+++ b/tests/gitlab.scm
@@ -157,30 +157,6 @@
     }
   }")
 
-(define (specifications-equal? spec1 spec2)
-  (and (eq? (specification-name spec1)
-            (specification-name spec2))
-       (equal? (specification-build spec1)
-               (specification-build spec2))
-       (= (specification-priority spec1)
-          (specification-priority spec2))
-       (= (specification-period spec1)
-          (specification-period spec2))
-       (equal? (specification-systems spec1)
-               (specification-systems spec2))
-       (equal? (map channel-name
-                    (specification-channels spec1))
-               (map channel-name
-                    (specification-channels spec2)))
-       (equal? (map channel-url
-                    (specification-channels spec1))
-               (map channel-url
-                    (specification-channels spec2)))
-       (equal? (map channel-branch
-                    (specification-channels spec1))
-               (map channel-branch
-                    (specification-channels spec2)))))
-
 (test-assert "default-json"
   (specifications-equal?
    (let ((event (json->gitlab-event default-mr-json)))

base-commit: e96f0887923d4d1cd4e35073fcffdb978d7e1e10
-- 
2.46.0





^ permalink raw reply related	[flat|nested] 5+ messages in thread

* [bug#74769] [PATCH Cuirass 2/4] forgejo: Add module for Forgejo JSON objects definition.
  2024-12-10 16:09 ` [bug#74769] [PATCH Cuirass 1/4] tests: Move procedure definition Romain GARBAGE
@ 2024-12-10 16:09   ` Romain GARBAGE
  2024-12-10 16:09   ` [bug#74769] [PATCH Cuirass 3/4] tests: Explicit Gitlab endpoint related variables Romain GARBAGE
  2024-12-10 16:09   ` [bug#74769] [PATCH Cuirass 4/4] http: Add admin/forgejo/event Romain GARBAGE
  2 siblings, 0 replies; 5+ messages in thread
From: Romain GARBAGE @ 2024-12-10 16:09 UTC (permalink / raw)
  To: 74769; +Cc: ludovic.courtes, Romain GARBAGE

* Makefile.am: Add src/cuirass/forgejo.scm and tests/forgejo.scm.
* src/cuirass/forgejo.scm: Add <forgejo-repository>,
<forgejo-pull-request-event>, <forgejo-pull-request>,
<forgejo-repository-reference> and <forgejo-repo> record types.
(forgejo-pull-request->specification): New variable.
* tests/forgejo.scm: Add tests.

fixup tests
---
 Makefile.am             |   2 +
 src/cuirass/forgejo.scm | 133 ++++++++++++++++++++++++++++++++++++++++
 tests/forgejo.scm       |  79 ++++++++++++++++++++++++
 3 files changed, 214 insertions(+)
 create mode 100644 src/cuirass/forgejo.scm
 create mode 100644 tests/forgejo.scm

diff --git a/Makefile.am b/Makefile.am
index 1123eb1..fca6b9f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -52,6 +52,7 @@ dist_pkgmodule_DATA =				\
   src/cuirass/store.scm				\
   src/cuirass/base.scm				\
   src/cuirass/database.scm			\
+  src/cuirass/forgejo.scm                       \
   src/cuirass/gitlab.scm                        \
   src/cuirass/http.scm				\
   src/cuirass/logging.scm			\
@@ -167,6 +168,7 @@ TESTS = \
 ## tests/basic.sh # takes too long to execute
   tests/store.scm \
   tests/database.scm \
+  tests/forgejo.scm \
   tests/gitlab.scm \
   tests/http.scm \
   tests/metrics.scm \
diff --git a/src/cuirass/forgejo.scm b/src/cuirass/forgejo.scm
new file mode 100644
index 0000000..9dda2c5
--- /dev/null
+++ b/src/cuirass/forgejo.scm
@@ -0,0 +1,133 @@
+;;; forgejo.scm -- Forgejo JSON mappings
+;;; Copyright © 2024 Romain Garbage <guix-devel@rgarbage.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 forgejo)
+  #:use-module (cuirass specification)
+  #:use-module (json)
+  #:use-module (web http)
+  #:use-module (guix channels)
+  #:use-module (ice-9 match)
+  #:export (forgejo-pull-request-event-pull-request
+            forgejo-pull-request-event-action
+            json->forgejo-pull-request-event
+
+            forgejo-repository-name
+            forgejo-repository-url
+
+            json->forgejo-pull-request
+
+            forgejo-pull-request->specification))
+
+;;; Commentary:
+;;;
+;;; This module implements a subset of the Forgejo Webhook API described at
+;;; <https://forgejo.org/docs/latest/user/webhooks/>.
+;;;
+;;; Code:
+
+;; This declares a specific header for internal consumption, specifically when
+;; generating requests during tests.
+(declare-opaque-header! "X-Forgejo-Event")
+
+(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"))
+
+;; This maps to the top level JSON object.
+(define-json-mapping <forgejo-pull-request-event>
+  make-forgejo-pull-request-event
+  forgejo-pull-request-event?
+  json->forgejo-pull-request-event
+  (action       forgejo-pull-request-event-action "action"
+                string->symbol)
+  (pull-request forgejo-pull-request-event-pull-request "pull_request"
+                json->forgejo-pull-request))
+
+(define-json-mapping <forgejo-pull-request>
+  make-forgejo-pull-request
+  forgejo-pull-request?
+  json->forgejo-pull-request
+  (number  forgejo-pull-request-number "number")
+  (base    forgejo-pull-request-base "base"
+           json->forgejo-repository-reference)
+  (head    forgejo-pull-request-head "head"
+           json->forgejo-repository-reference))
+
+;; This mapping is used to define various JSON objects such as "base" or
+;; "head".
+(define-json-mapping <forgejo-repository-reference>
+  make-forgejo-repository-reference
+  forgejo-repository-reference?
+  json->forgejo-repository-reference
+  (label      forgejo-repository-reference-label "label")
+  (ref        forgejo-repository-reference-ref "ref")
+  (sha        forgejo-repository-reference-sha "sha")
+  (repository forgejo-repository-reference-repository "repo"
+              json->forgejo-repository))
+
+(define* (forgejo-pull-request->specification pull-request #:optional (cuirass-options #f))
+  "Returns a SPECIFICATION built out of a FORGEJO-PULL-REQUEST."
+  (let* ((source-repo-reference (forgejo-pull-request-head pull-request))
+         (project-name (forgejo-repository-name
+                        (forgejo-repository-reference-repository
+                         (forgejo-pull-request-base pull-request))))
+         (source-branch (forgejo-repository-reference-ref source-repo-reference))
+         (source-url (forgejo-repository-url
+                      (forgejo-repository-reference-repository source-repo-reference)))
+         (id (forgejo-pull-request-number pull-request))
+         (name-prefix (if (and cuirass-options
+                               (jobset-options-name-prefix cuirass-options))
+                          (jobset-options-name-prefix cuirass-options)
+                          'forgejo-pull-requests))
+         (spec-name (string->symbol
+                     (format #f "~a-~a-~a-~a" name-prefix
+                             project-name
+                             source-branch
+                             id)))
+         (build (if (and cuirass-options
+                         (jobset-options-build cuirass-options))
+                    (jobset-options-build cuirass-options)
+                    `(channels ,project-name)))
+         (period (if (and cuirass-options
+                          (jobset-options-period cuirass-options))
+                     (jobset-options-period cuirass-options)
+                     3600))
+         (priority (if (and cuirass-options
+                            (jobset-options-priority cuirass-options))
+                       (jobset-options-priority cuirass-options)
+                       1))
+         (systems (if (and cuirass-options
+                           (jobset-options-systems cuirass-options))
+                      (jobset-options-systems cuirass-options)
+                      (list "x86_64-linux"))))
+    (specification
+     (name spec-name)
+     (build build)
+     (channels
+      (cons* (channel
+              (name project-name)
+              (url source-url)
+              (branch source-branch))
+             %default-channels))
+     (priority priority)
+     (period period)
+     (systems systems))))
diff --git a/tests/forgejo.scm b/tests/forgejo.scm
new file mode 100644
index 0000000..bb8f768
--- /dev/null
+++ b/tests/forgejo.scm
@@ -0,0 +1,79 @@
+;;; forgejo.scm -- tests for (cuirass forgejo) module
+;;; Copyright © 2024 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/>.
+
+(use-modules (cuirass forgejo)
+             (cuirass specification)
+             (cuirass utils)
+             (tests common)
+             (guix channels)
+             (json)
+             (fibers)
+             (squee)
+             (web uri)
+             (web client)
+             (web response)
+             (rnrs bytevectors)
+             (srfi srfi-1)
+             (srfi srfi-64)
+             (ice-9 threads)
+             (ice-9 match))
+
+(define default-pull-request-json
+  "{
+    \"action\": \"opened\",
+    \"pull_request\": {
+      \"number\": 1,
+      \"state\": \"open\",
+      \"base\": {
+        \"label\": \"base-label\",
+        \"ref\": \"base-branch\",
+        \"sha\": \"666af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
+        \"repo\": {
+          \"name\": \"project-name\",
+          \"clone_url\": \"https://forgejo.instance.test/base-repo/project-name.git\"
+        }
+      },
+      \"head\": {
+        \"label\": \"test-label\",
+        \"ref\": \"test-branch\",
+        \"sha\": \"582af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
+        \"repo\": {
+          \"name\": \"fork-name\",
+          \"clone_url\": \"https://forgejo.instance.test/source-repo/fork-name.git\"
+        }
+      }
+    }
+  }")
+
+(test-assert "default-json"
+  (specifications-equal?
+   (let ((event (json->forgejo-pull-request-event default-pull-request-json)))
+     (forgejo-pull-request->specification
+      (forgejo-pull-request-event-pull-request event)))
+   (specification
+    (name 'forgejo-pull-requests-project-name-test-branch-1)
+    (build '(channels . (project-name)))
+    (channels
+     (cons* (channel
+             (name 'project-name)
+             (url "https://forgejo.instance.test/source-repo/fork-name.git")
+             (branch "test-branch"))
+            %default-channels))
+    (priority 1)
+    (period 3600)
+    (systems (list "x86_64-linux")))))
-- 
2.46.0





^ permalink raw reply related	[flat|nested] 5+ messages in thread

* [bug#74769] [PATCH Cuirass 3/4] tests: Explicit Gitlab endpoint related variables.
  2024-12-10 16:09 ` [bug#74769] [PATCH Cuirass 1/4] tests: Move procedure definition Romain GARBAGE
  2024-12-10 16:09   ` [bug#74769] [PATCH Cuirass 2/4] forgejo: Add module for Forgejo JSON objects definition Romain GARBAGE
@ 2024-12-10 16:09   ` Romain GARBAGE
  2024-12-10 16:09   ` [bug#74769] [PATCH Cuirass 4/4] http: Add admin/forgejo/event Romain GARBAGE
  2 siblings, 0 replies; 5+ messages in thread
From: Romain GARBAGE @ 2024-12-10 16:09 UTC (permalink / raw)
  To: 74769; +Cc: ludovic.courtes, Romain GARBAGE

* tests/http.scm: Rename mr-* variables to gitlab-merge-request-*.
---
 tests/http.scm | 22 +++++++++++-----------
 1 file changed, 11 insertions(+), 11 deletions(-)

diff --git a/tests/http.scm b/tests/http.scm
index 7b8ab03..9712787 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -90,7 +90,7 @@
                      (channel . "packages")
                      (directory . "dir2")))))))
 
-(define mr-json-open
+(define gitlab-merge-request-json-open
   "{
     \"event_type\": \"merge_request\",
     \"project\": {
@@ -108,7 +108,7 @@
     }
   }")
 
-(define mr-json-close
+(define gitlab-merge-request-json-close
   "{
     \"event_type\": \"merge_request\",
     \"project\": {
@@ -126,8 +126,8 @@
     }
   }")
 
-(define mr-spec
-  (let ((event (json->gitlab-event mr-json-open)))
+(define gitlab-merge-request-spec
+  (let ((event (json->gitlab-event gitlab-merge-request-json-open)))
     (gitlab-merge-request->specification
      (gitlab-event-value event)
      (gitlab-event-project event))))
@@ -438,24 +438,24 @@
                          (specification-channels spec)))))))
 
    (test-equal "/admin/gitlab/event creates a spec from a new merge request"
-     (specification-name mr-spec)
+     (specification-name gitlab-merge-request-spec)
      (begin
-       (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-open)
-       (specification-name (db-get-specification (specification-name mr-spec)))))
+       (http-post-json (test-cuirass-uri "/admin/gitlab/event") gitlab-merge-request-json-open)
+       (specification-name (db-get-specification (specification-name gitlab-merge-request-spec)))))
 
    (test-equal "/admin/gitlab/event error when a merge request has already been created"
      400
-     (response-code (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-open)))
+     (response-code (http-post-json (test-cuirass-uri "/admin/gitlab/event") gitlab-merge-request-json-open)))
 
    (test-assert "/admin/gitlab/event removes a spec from a closed merge request"
      (begin
-       (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-close)
-       (not (db-get-specification (specification-name mr-spec)))))
+       (http-post-json (test-cuirass-uri "/admin/gitlab/event") gitlab-merge-request-json-close)
+       (not (db-get-specification (specification-name gitlab-merge-request-spec)))))
 
    (test-equal "/admin/gitlab/event error when a merge request has already been closed"
      404
      (response-code (http-post-json (test-cuirass-uri "/admin/gitlab/event")
-                                    mr-json-close)))
+                                    gitlab-merge-request-json-close)))
 
    (test-assert "db-close"
      (begin
-- 
2.46.0





^ permalink raw reply related	[flat|nested] 5+ messages in thread

* [bug#74769] [PATCH Cuirass 4/4] http: Add admin/forgejo/event.
  2024-12-10 16:09 ` [bug#74769] [PATCH Cuirass 1/4] tests: Move procedure definition Romain GARBAGE
  2024-12-10 16:09   ` [bug#74769] [PATCH Cuirass 2/4] forgejo: Add module for Forgejo JSON objects definition Romain GARBAGE
  2024-12-10 16:09   ` [bug#74769] [PATCH Cuirass 3/4] tests: Explicit Gitlab endpoint related variables Romain GARBAGE
@ 2024-12-10 16:09   ` Romain GARBAGE
  2 siblings, 0 replies; 5+ messages in thread
From: Romain GARBAGE @ 2024-12-10 16:09 UTC (permalink / raw)
  To: 74769; +Cc: ludovic.courtes, Romain GARBAGE

* src/cuirass/http.scm (url-handler): Add "/admin/forgejo/event".
* tests/http.scm: Add tests for the "/admin/forgejo/event" endpoint.
* doc/cuirass.texi: Reorganize "Interfacing Cuirass..." section. Add
documentation for the "/admin/forgejo/event" endpoint.
---
 doc/cuirass.texi     | 38 ++++++++++++++++--
 src/cuirass/http.scm | 62 +++++++++++++++++++++++++++++
 tests/http.scm       | 92 +++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 186 insertions(+), 6 deletions(-)

diff --git a/doc/cuirass.texi b/doc/cuirass.texi
index 13739c9..895d91f 100644
--- a/doc/cuirass.texi
+++ b/doc/cuirass.texi
@@ -1284,11 +1284,14 @@ This request accepts a mandatory parameter.
 Limit query result to nr elements. This parameter is @emph{mandatory}.
 @end table
 
-@section Interfacing Cuirass with a GitLab Server
+@section Interfacing Cuirass with a Git forge
 
-Cuirass supports integration with GitLab through the @dfn{webhook} mechanism:
-a POST request is sent by a GitLab instance whenever a specific event is
-triggered. So far, Cuirass only support merge-request events.
+Cuirass supports integration with various forges through the
+@dfn{webhook} mechanism: a POST request is sent by the forge instance
+whenever a specific event is triggered. So far, Cuirass only support
+merge-request/pull-request events.
+
+@subsection Interfacing with a GitLab Server
 
 Sending a merge request event on the @code{/admin/gitlab/event} endpoint
 allows controlling a specific jobset related to the merge request
@@ -1330,6 +1333,33 @@ A JSON list of strings.  Each string must be a supported system, i.e.
 @code{"systems": [ "x86_64-linux", "aarch64-linux" ]}
 @end table
 
+@subsection Interfacing with a Forgejo Server
+
+Sending a merge request event on the @code{/admin/forgejo/event}
+endpoint allows controlling a specific jobset related to the merge
+request content. This interface expect the JSON data to contain the
+following keys:
+@table @code
+@item "action"
+@item "pull_request.number"
+@item "pull_request.state"
+@item "pull_request.base.label"
+@item "pull_request.base.ref"
+@item "pull_request.base.sha"
+@item "pull_request.base.repo.name"
+@item "pull_request.base.repo.clone_url"
+@item "pull_request.head.label"
+@item "pull_request.head.ref"
+@item "pull_request.head.sha"
+@item "pull_request.head.repo.name"
+@item "pull_request.head.repo.clone_url"
+@end table
+
+The resulting jobset, named as
+@code{forgejo-pull-requests-@var{pull_request}.@var{base}.@var{pull_request}.@var{name}-@var{pull_request}.@var{head}.@var{ref}-@var{pull_request}.@var{number}},
+is set to build the channel corresponding to the source branch in the
+merge request data with a priority of 1.
+
 @c *********************************************************************
 @node Database
 @chapter Database schema
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 881e803..a9c3cda 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -27,6 +27,7 @@
   #:use-module (cuirass config)
   #:use-module (cuirass database)
   #:use-module ((cuirass base) #:select (evaluation-log-file))
+  #:use-module (cuirass forgejo)
   #:use-module (cuirass gitlab)
   #:use-module (cuirass metrics)
   #:use-module (cuirass utils)
@@ -779,6 +780,67 @@ return DEFAULT."
              (event-type (respond-json-with-error 400 (format #f "Event type \"~a\" not supported." event-type))))
            (respond-json-with-error 400 "This API only supports JSON."))))
 
+    ;; Define an API for Forgejo events
+    (('POST "admin" "forgejo" "event")
+     (let* ((params (utf8->string body))
+            (event-type (assoc-ref (request-headers request) 'x-forgejo-event))
+            (content-type (assoc-ref (request-headers request) 'content-type))
+            (json? (equal? (car content-type)
+                           'application/json)))
+       (if json?
+           (match event-type
+             ("pull_request"
+              (let* ((event (json->forgejo-pull-request-event params))
+                     (pull-request (forgejo-pull-request-event-pull-request event))
+                     (spec (forgejo-pull-request->specification pull-request))
+                     (spec-name (specification-name spec)))
+                (match (forgejo-pull-request-event-action event)
+                  ;; New pull request.
+                  ((or 'opened 'reopened)
+                   (if (not (db-get-specification spec-name))
+                       (begin
+                         (db-add-or-update-specification spec)
+
+                         (unless (call-bridge `(register-jobset ,spec-name)
+                                              bridge)
+                           (log-warning
+                            "cannot notify bridge of the addition of jobset '~a'"
+                            spec-name))
+                         (respond
+                          (build-response #:code 200
+                                          #:headers
+                                          `((location . ,(string->uri-reference "/"))))
+                          #:body ""))
+                       (begin
+                         (log-warning "jobset '~a' already exists" spec-name)
+                         (respond-json-with-error 400 "Jobset already exists."))))
+                  ;; Closed or merged pull request.
+                  ('closed
+                   (if (db-get-specification spec-name)
+                       (begin
+                         (call-bridge `(remove-jobset ,spec-name) bridge)
+                         (log-info "Removed jobset '~a'" spec-name)
+                         (respond
+                          (build-response #:code 200
+                                          #:headers
+                                          `((location . ,(string->uri-reference "/"))))
+                          #:body ""))
+                       (begin
+                         (log-warning "cannot find jobset '~a'" spec-name)
+                         (respond-json-with-error 404 "Jobset not found."))))
+                  ;; Pull request is updated.
+                  ('synchronized
+                   (if (db-get-specification spec-name)
+                       (if (call-bridge `(trigger-jobset ,(specification-name spec))
+                                        bridge)
+                           (respond-json (scm->json-string `((jobset . ,spec-name))))
+                           (begin
+                             (log-warning "evaluation hook disabled")
+                             (respond-json-with-error 400 "Evaluation hook disabled.")))
+                       (respond-json-with-error 404 "Jobset not found."))))))
+             (_ (respond-json-with-error 400 (format #f "Event type \"~a\" not supported." event-type))))
+           (respond-json-with-error 400 "This API only supports JSON."))))
+
     (('POST "admin" "specification" "add")
      (let* ((spec (body->specification body))
             (name (specification-name spec)))
diff --git a/tests/http.scm b/tests/http.scm
index 9712787..9393043 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -22,6 +22,7 @@
 (use-modules ((cuirass base) #:select (%bridge-socket-file-name))
              (cuirass http)
              (cuirass database)
+             (cuirass forgejo)
              (cuirass gitlab)
              (cuirass specification)
              (cuirass utils)
@@ -43,8 +44,9 @@
   (call-with-values (lambda () (http-get uri))
     (lambda (response body) body)))
 
-(define (http-post-json uri body)
-  (http-post uri #:body body #:headers '((content-type application/json))))
+(define* (http-post-json uri body #:optional (extra-headers '()))
+  (http-post uri #:body body #:headers (append '((content-type application/json))
+                                               extra-headers)))
 
 (define (wait-until-ready port)
   ;; Wait until the server is accepting connections.
@@ -132,6 +134,65 @@
      (gitlab-event-value event)
      (gitlab-event-project event))))
 
+(define forgejo-pull-request-json-open
+  "{
+    \"action\": \"opened\",
+    \"pull_request\": {
+      \"number\": 1,
+      \"state\": \"open\",
+      \"base\": {
+        \"label\": \"base-label\",
+        \"ref\": \"base-branch\",
+        \"sha\": \"666af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
+        \"repo\": {
+          \"name\": \"project-name\",
+          \"clone_url\": \"https://forgejo.instance.test/base-repo/project-name.git\"
+        }
+      },
+      \"head\": {
+        \"label\": \"test-label\",
+        \"ref\": \"test-branch\",
+        \"sha\": \"582af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
+        \"repo\": {
+          \"name\": \"fork-name\",
+          \"clone_url\": \"https://forgejo.instance.test/source-repo/fork-name.git\"
+        }
+      }
+    }
+  }")
+
+(define forgejo-pull-request-json-close
+  "{
+    \"action\": \"closed\",
+    \"pull_request\": {
+      \"number\": 1,
+      \"state\": \"closed\",
+      \"base\": {
+        \"label\": \"base-label\",
+        \"ref\": \"base-branch\",
+        \"sha\": \"666af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
+        \"repo\": {
+          \"name\": \"project-name\",
+          \"clone_url\": \"https://forgejo.instance.test/base-repo/project-name.git\"
+        }
+      },
+      \"head\": {
+        \"label\": \"test-label\",
+        \"ref\": \"test-branch\",
+        \"sha\": \"582af40e8a059fa05c7048a7ac4f2eccbbd0183b\",
+        \"repo\": {
+          \"name\": \"fork-name\",
+          \"clone_url\": \"https://forgejo.instance.test/source-repo/fork-name.git\"
+        }
+      }
+    }
+  }")
+
+(define forgejo-pull-request-specification
+  (forgejo-pull-request->specification
+   (forgejo-pull-request-event-pull-request
+    (json->forgejo-pull-request-event forgejo-pull-request-json-open))))
+
 (define-syntax-rule (with-cuirass-register exp ...)
   (with-guix-daemon
    (let ((pid #f))
@@ -457,6 +518,33 @@
      (response-code (http-post-json (test-cuirass-uri "/admin/gitlab/event")
                                     gitlab-merge-request-json-close)))
 
+   (test-equal "/admin/forgejo/event creates a spec from a new pull request"
+     (specification-name forgejo-pull-request-specification)
+     (begin
+       (http-post-json (test-cuirass-uri "/admin/forgejo/event")
+                       forgejo-pull-request-json-open
+                       '((x-forgejo-event . "pull_request")))
+       (specification-name (db-get-specification (specification-name forgejo-pull-request-specification)))))
+
+   (test-equal "/admin/forgejo/event error when a pull request has already been created"
+     400
+     (response-code (http-post-json (test-cuirass-uri "/admin/forgejo/event")
+                                    forgejo-pull-request-json-open
+                                    '((x-forgejo-event . "pull_request")))))
+
+   (test-assert "/admin/forgejo/event removes a spec from a closed pull request"
+     (begin
+       (http-post-json (test-cuirass-uri "/admin/forgejo/event")
+                       forgejo-pull-request-json-close
+                       '((x-forgejo-event . "pull_request")))
+       (not (db-get-specification (specification-name forgejo-pull-request-specification)))))
+
+   (test-equal "/admin/forgejo/event error when a pull request has already been closed"
+     404
+     (response-code (http-post-json (test-cuirass-uri "/admin/forgejo/event")
+                                    forgejo-pull-request-json-close
+                                    '((x-forgejo-event . "pull_request")))))
+
    (test-assert "db-close"
      (begin
        (db-close (%db))
-- 
2.46.0





^ permalink raw reply related	[flat|nested] 5+ messages in thread

end of thread, other threads:[~2024-12-10 16:10 UTC | newest]

Thread overview: 5+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-12-10 16:01 [bug#74769] [PATCH Cuirass 0/4] Forgejo event support Romain GARBAGE
2024-12-10 16:09 ` [bug#74769] [PATCH Cuirass 1/4] tests: Move procedure definition Romain GARBAGE
2024-12-10 16:09   ` [bug#74769] [PATCH Cuirass 2/4] forgejo: Add module for Forgejo JSON objects definition Romain GARBAGE
2024-12-10 16:09   ` [bug#74769] [PATCH Cuirass 3/4] tests: Explicit Gitlab endpoint related variables Romain GARBAGE
2024-12-10 16:09   ` [bug#74769] [PATCH Cuirass 4/4] http: Add admin/forgejo/event Romain GARBAGE

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).