1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
| | ;;;; gitlab.scm -- Gitlab JSON mappings
;;; Copyright © 2024 Romain Garbage <guix-devel@rgarbage.fr>
;;;
;;; 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))
(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")))))
|