147 lines
6.2 KiB
Scheme
147 lines
6.2 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 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
|
|
mark-pull-request-branch-for-deletion))
|
|
|
|
;; 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))))
|
|
|
|
(define (mark-pull-request-branch-for-deletion conn pull-request)
|
|
"Mark the branch associated with @var{pull-request}, a pull request being
|
|
closed, for deletion."
|
|
(let* ((url (forgejo-pull-request-url pull-request))
|
|
(repository-id (git-repository-url->git-repository-id
|
|
conn url #:create-if-missing? #f)))
|
|
(when repository-id
|
|
(let* ((date (time-utc->date (current-time time-utc)))
|
|
(reference (forgejo-pull-request-head pull-request))
|
|
(branch (forgejo-repository-reference-ref reference))
|
|
(branch-id (git-branch-for-repository-and-name
|
|
conn repository-id branch)))
|
|
(when branch-id
|
|
;; Insert a commit entry with the empty string: this is interpreted
|
|
;; as BRANCH-ID being a candidate for deletion.
|
|
(format #t "marking pull request branch ~s of ~s for deletion~%"
|
|
branch url)
|
|
(insert-git-commit-entry conn branch-id "" date))))))
|