[bug#74769] [PATCH Cuirass v2 5/7] forgejo: Add module for Forgejo JSON objects definition.

[Romain GARBAGE]

* Makefile.am: Add src/cuirass/forges/forgejo.scm and tests/forgejo.scm.
* src/cuirass/forges/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.
---
 Makefile.am                    |   2 +
 src/cuirass/forges/forgejo.scm | 134 +++++++++++++++++++++++++++++++++
 tests/forgejo.scm              |  80 ++++++++++++++++++++
 3 files changed, 216 insertions(+)
 create mode 100644 src/cuirass/forges/forgejo.scm
 create mode 100644 tests/forgejo.scm

diff --git a/Makefile.am b/Makefile.am
index 2de3419..f38703e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -53,6 +53,7 @@ dist_pkgmodule_DATA =                         \
   src/cuirass/base.scm                         \
   src/cuirass/database.scm                     \
   src/cuirass/forges.scm                        \
+  src/cuirass/forges/forgejo.scm                \
   src/cuirass/forges/gitlab.scm                 \
   src/cuirass/http.scm                         \
   src/cuirass/logging.scm                      \
@@ -168,6 +169,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/forges/forgejo.scm b/src/cuirass/forges/forgejo.scm
new file mode 100644
index 0000000..11133f4
--- /dev/null
+++ b/src/cuirass/forges/forgejo.scm
@@ -0,0 +1,134 @@
+;;; forgejo.scm -- Forgejo JSON mappings
+;;; 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/>.
+
+(define-module (cuirass forges forgejo)
+  #:use-module (cuirass specification)
+  #:use-module (cuirass forges)
+  #: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)
+                     %default-jobset-options-period))
+         (priority (if (and cuirass-options
+                            (jobset-options-priority cuirass-options))
+                       (jobset-options-priority cuirass-options)
+                       %default-jobset-options-priority))
+         (systems (if (and cuirass-options
+                           (jobset-options-systems cuirass-options))
+                      (jobset-options-systems cuirass-options)
+                      %default-jobset-options-systems)))
+    (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..fb3e99f
--- /dev/null
+++ b/tests/forgejo.scm
@@ -0,0 +1,80 @@
+;;; 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 forges)
+             (cuirass forges 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=?
+   (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 %default-jobset-options-priority)
+    (period %default-jobset-options-period)
+    (systems %default-jobset-options-systems))))
-- 
2.46.0