cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add support for Forgejo web hooks.

Browse source 
Populate the ‘git_repositories’ and ‘load_new_guix_revision_jobs’ table
when receiving a POST request corresponding to a Forgejo pull-request
webhook.
This commit is contained in:
Ludovic Courtès 2025-05-13 16:30:53 +02:00
parent ff7697477f
commit 30b2d91bfb
5 changed files with 354 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

3
Makefile.am
View file

@ -79,6 +79,7 @@ SOURCES = \
guix-data-service/substitutes.scm \ guix-data-service/substitutes.scm \
guix-data-service/utils.scm \ guix-data-service/utils.scm \
guix-data-service/data-deletion.scm \ guix-data-service/data-deletion.scm \
guix-data-service/forgejo.scm \
guix-data-service/jobs.scm \ guix-data-service/jobs.scm \
guix-data-service/jobs/load-new-guix-revision.scm \ guix-data-service/jobs/load-new-guix-revision.scm \
guix-data-service/model/blocked-builds.scm \ guix-data-service/model/blocked-builds.scm \
@ -120,6 +121,7 @@ SOURCES = \
guix-data-service/web/package/html.scm \ guix-data-service/web/package/html.scm \
guix-data-service/web/dumps/html.scm \ guix-data-service/web/dumps/html.scm \
guix-data-service/web/controller.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/html-utils.scm \
guix-data-service/web/jobs/controller.scm \ guix-data-service/web/jobs/controller.scm \
guix-data-service/web/jobs/html.scm \ guix-data-service/web/jobs/html.scm \
@ -142,6 +144,7 @@ TEST_EXTENSIONS = .scm
TESTS = \ TESTS = \
tests/branch-updated-emails.scm \ tests/branch-updated-emails.scm \
tests/forgejo.scm \
tests/jobs-load-new-guix-revision.scm \ tests/jobs-load-new-guix-revision.scm \
tests/model-derivation.scm \ tests/model-derivation.scm \
tests/model-git-branch.scm \ tests/model-git-branch.scm \

127
guix-data-service/forgejo.scm Normal file
View file

@ -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))))

3
guix-data-service/web/controller.scm
View file

@ -73,6 +73,7 @@
#:use-module (guix-data-service web revision controller) #:use-module (guix-data-service web revision controller)
#:use-module (guix-data-service web repository controller) #:use-module (guix-data-service web repository controller)
#:use-module (guix-data-service web package controller) #:use-module (guix-data-service web package controller)
#:use-module (guix-data-service web forgejo controller)
#:export (%show-error-details #:export (%show-error-details
handle-static-assets handle-static-assets
make-render-metrics make-render-metrics
@ -821,6 +822,8 @@
(delegate-to repository-controller)) (delegate-to repository-controller))
(('GET "repository" _ ...) (('GET "repository" _ ...)
(delegate-to repository-controller)) (delegate-to repository-controller))
(('POST "forgejo" _ ...)
(delegate-to forgejo-controller))
(('GET "package" _ ...) (('GET "package" _ ...)
(delegate-to package-controller)) (delegate-to package-controller))
(('GET "gnu" "store" filename) (('GET "gnu" "store" filename)

87
guix-data-service/web/forgejo/controller.scm Normal file
View file

@ -0,0 +1,87 @@
;;; 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 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
;;; <https://forgejo.org/docs/latest/user/webhooks/> and a subset of the REST
;;; API described at <https://codeberg.org/api/swagger>.
;;;
;;; 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))))

134
tests/forgejo.scm Normal file
View file

@ -0,0 +1,134 @@
;;; forgejo.scm -- Test support for Forgejo pull requests
;;; Copyright © 2024, 2025 Romain Garbage <romain.garbage@inria.fr>
;;; Copyright © 2025 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 (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)