[bug#74769] [PATCH Cuirass v2 7/7] http: Add admin/forgejo/event.

[Romain GARBAGE <romain.garbage@inria.fr>]

* 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 | 64 +++++++++++++++++++++++++++++-
 tests/http.scm       | 93 +++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 188 insertions(+), 7 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 8ea929f..0a6bfae 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -5,7 +5,7 @@
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
 ;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2024 Romain Garbage <guix-devel@rgarbage.fr>
+;;; Copyright © 2024 Romain Garbage <romain.garbage@inria.fr>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -28,6 +28,7 @@
   #:use-module (cuirass database)
   #:use-module ((cuirass base) #:select (evaluation-log-file))
   #:use-module (cuirass forges gitlab)
+  #:use-module (cuirass forges forgejo)
   #:use-module (cuirass metrics)
   #:use-module (cuirass utils)
   #:use-module (cuirass logging)
@@ -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 aa58e78..862e06b 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017-2020, 2023-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2024 Romain Garbage <romain.garbage@inria.fr>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -22,6 +23,7 @@
 (use-modules ((cuirass base) #:select (%bridge-socket-file-name))
              (cuirass http)
              (cuirass database)
+             (cuirass forges forgejo)
              (cuirass forges gitlab)
              (cuirass specification)
              (cuirass utils)
@@ -43,8 +45,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 +135,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 +519,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