b35c26a74e
Fixes the bug reported in <https://codeberg.org/guix/maintenance/pulls/18#issuecomment-5851510>. Previously ‘forgejo-controller’ would return a single value in successful cases, whichever ‘enqueue-job-for-pull-request’ or ‘mark-pull-request-branch-for-deletion’ would return.
90 lines
3.9 KiB
Scheme
90 lines
3.9 KiB
Scheme
;;; 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)
|
||
(render-json '() #:code 200))
|
||
('synchronized ;pull request is updated
|
||
(enqueue-job-for-pull-request conn pull-request)
|
||
(render-json '() #:code 200))
|
||
('closed ;closed or merged
|
||
(mark-pull-request-branch-for-deletion conn pull-request)
|
||
(render-json '() #:code 200))
|
||
(_ ;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))))
|