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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
;;; Guix QA Frontpage
;;;
;;; Copyright © 2022 Christopher Baines <mail@cbaines.net>
;;;
;;; 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-qa-frontpage derivation-changes)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (builds-by-system-excluding-cross-builds
categorise-builds))
(define (builds-by-system-excluding-cross-builds derivation-changes side)
(fold (lambda (package result)
(fold
(lambda (change result)
(if (string=? (assoc-ref change "target")
"")
(let ((system (assoc-ref change "system")))
`((,system
. ,(append!
(map
(lambda (build)
`(,@build
("package"
. (("name" . ,(assoc-ref package "name"))
("version" . ,(assoc-ref package "version"))))))
(vector->list (assoc-ref change "builds")))
(or (assoc-ref result system)
'())))
,@(alist-delete system result)))
result))
result
(vector->list
(assoc-ref package side))))
'()
derivation-changes))
(define (categorise-builds all-systems builds-by-system)
(define (package-eq? a b)
(and
(string=?
(assoc-ref a "name")
(assoc-ref b "name"))
(string=?
(assoc-ref a "version")
(assoc-ref b "version"))))
(define (group-builds-by-package builds)
(let ((result (make-hash-table)))
(for-each
(lambda (build)
(let ((package (assoc-ref build "package")))
(hash-set! result
package
(cons build
(or (hash-ref result package)
'())))))
builds)
(hash-map->list cons result)))
(define systems
(map car builds-by-system))
(map
(match-lambda
((system . builds)
(let ((builds-by-package
(group-builds-by-package builds)))
(cons
system
(fold
(match-lambda*
(((package . builds) result)
(let* ((build-statuses
;; Invent a new status here "blocked"
(map (lambda (build)
(let ((status
(assoc-ref build "status")))
(if (and (string=? status "scheduled")
(assoc-ref build "potentially_blocked"))
"blocked"
status)))
builds))
(category
(cond
((member "succeeded" build-statuses)
'succeeding)
((and (not (member "suceeded" build-statuses))
(member "failed" build-statuses))
'failing)
((member "blocked" build-statuses)
'blocked)
(else
'unknown))))
`((,category . ,(cons
(cons package builds)
(assq-ref result category)))
,@(alist-delete category result)))))
'((succeeding . ())
(failing . ())
(blocked . ())
(unknown . ()))
builds-by-package)))))
(append builds-by-system
(map (lambda (system)
(cons system '()))
(filter (lambda (system)
(not (member system systems)))
all-systems)))))
|