Add support for Forgejo web hooks.

Populate the ‘git_repositories’ and ‘load_new_guix_revision_jobs’ table
when receiving a POST request corresponding to a Forgejo pull-request
webhook.

guix-data-service/forgejo.scm

@@ -0,0 +1,127 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2024, 2025 Romain Garbage <romain.garbage@inria.fr>
+;;; Copyright © 2025 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program 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
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (guix-data-service forgejo)
+  #:use-module (json)
+  #:use-module (squee)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (guix channels)
+  #:use-module ((guix diagnostics) #:select (guix-warning-port))
+  #:use-module ((guix store) #:select (with-store))
+  #:use-module (guix-data-service database)
+  #:use-module (guix-data-service model git-branch)
+  #:use-module (guix-data-service model git-commit)
+  #:use-module (guix-data-service model git-repository)
+  #:use-module (guix-data-service jobs load-new-guix-revision)
+  #:export (json->forgejo-pull-request-event
+
+            forgejo-pull-request-event?
+            forgejo-pull-request-event-action
+            forgejo-pull-request-event-pull-request
+
+            forgejo-pull-request?
+            forgejo-pull-request-number
+            forgejo-pull-request-url
+            forgejo-pull-request-base
+            forgejo-pull-request-head
+            forgejo-pull-request-draft?
+            forgejo-pull-request-body
+
+            enqueue-job-for-pull-request))
+
+;; The JSON data structures below were copied from Cuirass.
+
+(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)
+  (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>
+  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")
+  (url     forgejo-pull-request-url)
+  (base    forgejo-pull-request-base "base"
+           json->forgejo-repository-reference)
+  (head    forgejo-pull-request-head "head"
+           json->forgejo-repository-reference)
+  (draft?  forgejo-pull-request-draft? "draft")
+  (body    forgejo-pull-request-body))
+
+;; 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 (enqueue-job-for-pull-request conn pull-request)
+  "Enqueue the Git repository of @var{pull-request} for eventual processing."
+  (if (forgejo-pull-request-draft? pull-request)
+      (format #t "skipping Forgejo pull request draft ~s~%"
+              (forgejo-pull-request-url pull-request))
+      (let* ((url (forgejo-pull-request-url pull-request))
+             (repository-id (git-repository-url->git-repository-id
+                             conn url
+                             ;; Disable channel authentication for PRs.
+                             #:authenticate? #f))
+             (date (time-utc->date (current-time time-utc))) ;XXX: approximate?
+             (reference (forgejo-pull-request-head pull-request))
+             (branch (forgejo-repository-reference-ref reference))
+             (commit (forgejo-repository-reference-sha reference))
+             (label (forgejo-repository-reference-label reference))
+
+             (branch-id (or (git-branch-for-repository-and-name
+                             conn repository-id branch)
+                            (insert-git-branch-entry
+                             conn repository-id branch))))
+        (unless (git-commit-exists? conn commit)
+          (insert-git-commit-entry conn branch-id commit date))
+
+        (enqueue-load-new-guix-revision-job conn repository-id
+                                            commit label))))