branch: main
commit 10cf59f2e847604d3baf97a97ec181f4b2844451
Author: Romain GARBAGE <[email protected]>
AuthorDate: Thu Jun 13 13:03:07 2024 +0200
gitlab: Add module for Gitlab JSON objects definition.
* Makefile.am: Add src/cuirass/gitlab.scm.
* src/cuirass/gitlab.scm: Add <gitlab-event> and <gitlab-merge-request>
record
types.
(gitlab-merge-request->specification): New variable.
Co-authored-by: Ludovic Courtès <[email protected]>
---
Makefile.am | 1 +
src/cuirass/gitlab.scm | 102 +++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 103 insertions(+)
diff --git a/Makefile.am b/Makefile.am
index c58bf58..4a066d3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -52,6 +52,7 @@ dist_pkgmodule_DATA = \
src/cuirass/store.scm \
src/cuirass/base.scm \
src/cuirass/database.scm \
+ src/cuirass/gitlab.scm \
src/cuirass/http.scm \
src/cuirass/logging.scm \
src/cuirass/mail.scm \
diff --git a/src/cuirass/gitlab.scm b/src/cuirass/gitlab.scm
new file mode 100644
index 0000000..0f4a8e8
--- /dev/null
+++ b/src/cuirass/gitlab.scm
@@ -0,0 +1,102 @@
+;;;; gitlab.scm -- Gitlab JSON mappings
+;;; Copyright © 2024 Romain Garbage <[email protected]>
+;;;
+;;; 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 (cuirass gitlab)
+ #:use-module (cuirass specification)
+ #:use-module (json)
+ #:use-module (guix channels)
+ #:use-module (ice-9 match)
+ #:export (gitlab-event
+ gitlab-event-type
+ gitlab-event-value
+ json->gitlab-event
+
+ gitlab-merge-request
+ gitlab-merge-request-action
+ gitlab-merge-request-project-name
+ json->gitlab-merge-request
+ gitlab-merge-request->specification))
+
+;;; Commentary:
+;;;
+;;; This module implements a subset of the GitLab Webhook API described at
+;;; <https://docs.gitlab.com/ee/user/project/integrations/webhook_events.html>.
+;;;
+;;; Code:
+
+(define-json-mapping <gitlab-source>
+ make-gitlab-source
+ gitlab-source?
+ json->gitlab-source
+ (repo-url gitlab-source-repo-url "git_http_url")
+ (name gitlab-source-name "name"
+ string->symbol))
+
+(define-json-mapping <gitlab-merge-request>
+ make-gitlab-merge-request
+ gitlab-merge-request?
+ json->gitlab-merge-request
+ (action gitlab-merge-request-action "action")
+ (source-branch gitlab-merge-request-source-branch "source_branch")
+ (source gitlab-merge-request-source "source"
+ json->gitlab-source))
+
+(define-json-mapping <gitlab-event>
+ make-gitlab-event
+ gitlab-event?
+ json->gitlab-event
+ (type gitlab-event-type "event_type"
+ (lambda (v)
+ (string->symbol
+ (string-map (lambda (c)
+ (if (char=? c #\_)
+ #\-
+ c))
+ v))))
+ (value gitlab-event-value "object_attributes"
+ (lambda (v)
+ ;; FIXME: properly handle cases using field TYPE defined above.
+ ;; This would need to use something like Guix's define-record-type*.
+ (cond
+ ((assoc-ref v "merge_status")
+ (json->gitlab-merge-request v))
+ (#t #f)))))
+
+(define (gitlab-merge-request->specification merge-request)
+ "Returns a SPECIFICATION built out of a GITLAB-MERGE-REQUEST."
+ (let* ((source-name (gitlab-source-name
+ (gitlab-merge-request-source merge-request)))
+ (source-branch (gitlab-merge-request-source-branch merge-request))
+ (source-url (gitlab-source-repo-url
+ (gitlab-merge-request-source merge-request)))
+ (spec-name (symbol-append 'gitlab-merge-requests-
+ source-name
+ '-
+ (string->symbol source-branch))))
+ (specification
+ (name spec-name)
+ (build `(channels ,source-name))
+ (channels
+ (cons* (channel
+ (name source-name)
+ (url source-url)
+ (branch source-branch))
+ %default-channels))
+ (priority 1)
+ (period 0)
+ (systems (list "x86_64-linux")))))
