diff --git a/Makefile.am b/Makefile.am index bf4cefe..608293b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -79,6 +79,7 @@ SOURCES = \ guix-data-service/substitutes.scm \ guix-data-service/utils.scm \ guix-data-service/data-deletion.scm \ + guix-data-service/forgejo.scm \ guix-data-service/jobs.scm \ guix-data-service/jobs/load-new-guix-revision.scm \ guix-data-service/model/blocked-builds.scm \ @@ -120,6 +121,7 @@ SOURCES = \ guix-data-service/web/package/html.scm \ guix-data-service/web/dumps/html.scm \ guix-data-service/web/controller.scm \ + guix-data-service/web/forgejo/controller.scm \ guix-data-service/web/html-utils.scm \ guix-data-service/web/jobs/controller.scm \ guix-data-service/web/jobs/html.scm \ @@ -142,6 +144,7 @@ TEST_EXTENSIONS = .scm TESTS = \ tests/branch-updated-emails.scm \ + tests/forgejo.scm \ tests/jobs-load-new-guix-revision.scm \ tests/model-derivation.scm \ tests/model-git-branch.scm \ diff --git a/guix-data-service/forgejo.scm b/guix-data-service/forgejo.scm new file mode 100644 index 0000000..5649a6b --- /dev/null +++ b/guix-data-service/forgejo.scm @@ -0,0 +1,127 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2024, 2025 Romain Garbage +;;; Copyright © 2025 Ludovic Courtès +;;; +;;; 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 +;;; . + +(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 + make-forgejo-owner + forgejo-owner? + json->forgejo-owner + (login forgejo-owner-login)) + +(define-json-mapping + 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 + 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 + 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 + 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)))) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 35055b5..6d63de2 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -73,6 +73,7 @@ #:use-module (guix-data-service web revision controller) #:use-module (guix-data-service web repository controller) #:use-module (guix-data-service web package controller) + #:use-module (guix-data-service web forgejo controller) #:export (%show-error-details handle-static-assets make-render-metrics @@ -821,6 +822,8 @@ (delegate-to repository-controller)) (('GET "repository" _ ...) (delegate-to repository-controller)) + (('POST "forgejo" _ ...) + (delegate-to forgejo-controller)) (('GET "package" _ ...) (delegate-to package-controller)) (('GET "gnu" "store" filename) diff --git a/guix-data-service/web/forgejo/controller.scm b/guix-data-service/web/forgejo/controller.scm new file mode 100644 index 0000000..b77efd1 --- /dev/null +++ b/guix-data-service/web/forgejo/controller.scm @@ -0,0 +1,87 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2024, 2025 Romain Garbage +;;; Copyright © 2025 Ludovic Courtès +;;; +;;; 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 +;;; . + +(define-module (guix-data-service web forgejo controller) + #:use-module (web http) + #:use-module (web request) + #:use-module (ice-9 match) + #:use-module ((rnrs bytevectors) #:select (utf8->string)) + #:use-module (knots resource-pool) + #:use-module (guix-data-service forgejo) + #:use-module (guix-data-service web controller) + #:use-module (guix-data-service web render) + #:export (forgejo-controller)) + +;;; Commentary: +;;; +;;; This module implements a subset of the Forgejo Webhook API described at +;;; and a subset of the REST +;;; API described at . +;;; +;;; Code: + +;; This declares a specific header for internal consumption, specifically when +;; generating requests during tests. +(declare-opaque-header! "X-Forgejo-Event") + + + +;;; +;;; Webhook. +;;; + +(define (forgejo-controller request + method-and-path-components + mime-types + body) + (match method-and-path-components + (('POST "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)) + (action (forgejo-pull-request-event-action event))) + (format #t "received pull request ~a ~s (action: ~a)~%" + (forgejo-pull-request-number pull-request) + (forgejo-pull-request-url pull-request) + action) + (call-with-resource-from-pool (connection-pool) + (lambda (conn) + (match action + ((or 'opened 'reopened) ;new pull request + (enqueue-job-for-pull-request conn pull-request)) + ('synchronized ;pull request is updated + (enqueue-job-for-pull-request conn pull-request)) + ('closed ;closed or merged + #f) + (_ ;other action + (render-json '((error . "unknown action")) + #:code 404))))))) + (_ + (render-json '((error . "unknown event type")) + #:code 404))) + (render-html #:code 400 + #:sxml "This HTTP endpoint requires JSON.")))) + (_ + (render-html #:code 404)))) diff --git a/tests/forgejo.scm b/tests/forgejo.scm new file mode 100644 index 0000000..5c41aad --- /dev/null +++ b/tests/forgejo.scm @@ -0,0 +1,134 @@ +;;; forgejo.scm -- Test support for Forgejo pull requests +;;; Copyright © 2024, 2025 Romain Garbage +;;; Copyright © 2025 Ludovic Courtès +;;; +;;; 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 . + +(define-module (test-forgejo) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match) + #:use-module ((ice-9 string-fun) #:select (string-replace-substring)) + #:use-module (guix-data-service database) + #:use-module (guix-data-service model git-repository) + #:use-module (guix-data-service model git-commit) + #:use-module (guix-data-service forgejo)) + +(define pull-request-url + "https://forgejo.example.org/base-repo/pulls/1") + +(define pull-request-commit + "582af40e8a059fa05c7048a7ac4f2eccbbd0183b") + +(define pull-request-new-commit + (string-reverse pull-request-commit)) + +(define pull-request-event-json + (string-append "{ + \"action\": \"opened\", + \"pull_request\": { + \"number\": 1, + \"state\": \"open\", + \"draft\": false, + \"url\": \"" pull-request-url "\", + \"body\": \"Some 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.example.org/base-repo/project-name.git\", + \"html_url\": \"https://forgejo.example.org/base-repo/project-name\" + } + }, + \"head\": { + \"label\": \"test-label\", + \"ref\": \"test-branch\", + \"sha\": \"" pull-request-commit "\", + \"repo\": { + \"owner\": { + \"login\": \"fork-owner\" + }, + \"name\": \"fork-name\", + \"full_name\": \"fork-owner/fork-name\", + \"clone_url\": \"https://forgejo.example.org/source-repo/fork-name.git\", + \"html_url\": \"https://forgejo.example.org/source-repo/fork-name\" + } + } + } + }")) + +(test-begin "forgejo") + +(with-postgresql-connection + "test-forgejo" + (lambda (conn) + (check-test-database! conn) + + (with-postgresql-transaction + conn + (lambda (conn) + (test-assert "enqueue-job-for-pull-request, initial commit" + (let* ((event (json->forgejo-pull-request-event + pull-request-event-json)) + (pull (forgejo-pull-request-event-pull-request event))) + (enqueue-job-for-pull-request conn pull))) + + (test-equal "all-git-repositories" + `((label . #f) + (url . ,pull-request-url) + (link-url . #f) + (x-git-repo-header . #f) + (included-branches . #f) + (excluded-branches . #f) + (fetch-with-authentication? . #f) ;authentication disabled for PRs + (query-substitutes? . #t) + (poll-interval . #f) + (job-priority . 0) + (commit-link-url-template . #f) + (commit-range-link-url-template . #f) + (file-link-url-template . #f)) + (match (find (lambda (alist) + (equal? (assoc-ref alist 'url) pull-request-url)) + (all-git-repositories conn)) + ((('id . id) rest ...) + ;; Since the ID might vary depending on other tests run on this + ;; database, strip it. + rest))) + + (test-assert "git-commit-exists?, initial commit" + (and (git-commit-exists? conn pull-request-commit) + (not (git-commit-exists? conn pull-request-new-commit)))) + + (test-assert "enqueue-job-for-pull-request, updating pull request" + (let* ((event (json->forgejo-pull-request-event + (string-replace-substring pull-request-event-json + pull-request-commit + pull-request-new-commit))) + (pull (forgejo-pull-request-event-pull-request event))) + (enqueue-job-for-pull-request conn pull))) + + (test-assert "git-commit-exists?, new commit" + (git-commit-exists? conn pull-request-new-commit))) + + #:always-rollback? #t))) + +(test-end)