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.
This commit is contained in:
Ludovic Courtès
parent
ff7697477f
commit
30b2d91bfb
5 changed files with 354 additions and 0 deletions
127
guix-data-service/forgejo.scm
Normal file
127
guix-data-service/forgejo.scm
Normal 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))))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
87
guix-data-service/web/forgejo/controller.scm
Normal file
87
guix-data-service/web/forgejo/controller.scm
Normal 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))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue