blob: 1283082118cd998e1d9bd290df0ba6e8a817a077 (
plain)
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
126
127
128
|
;;; 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 (categorise-packages
derivation-changes-counts))
(define (categorise-packages derivation-changes side)
(fold
(match-lambda*
((package result)
(fold
;; builds for specific system and target
(lambda (details result)
(let* ((system (assoc-ref details "system"))
(target (assoc-ref details "target"))
(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)))
(vector->list
(assoc-ref details "builds"))))
(category
(cond
((member "succeeded" build-statuses)
'succeeding)
((and (not (member "succeeded" build-statuses))
(member "failed" build-statuses))
'failing)
((member "blocked" build-statuses)
'blocked)
(else
'unknown))))
(let* ((system+target
(if (string-null? target)
system
(cons system target)))
(categorised-packages
(or (assoc-ref result system+target)
'())))
`((,system+target
.
((,category . ,(cons
(cons (assoc-ref package "name")
(assoc-ref package "version"))
(or (assq-ref categorised-packages category)
'())))
,@(alist-delete category categorised-packages)))
,@(alist-delete system+target result)))))
result
(vector->list
(assoc-ref package side)))))
'()
derivation-changes))
(define (derivation-changes-counts derivation-changes all-systems)
(let* ((categorised-base-packages-by-system
(categorise-packages derivation-changes "base"))
(categorised-target-packages-by-system
(categorise-packages derivation-changes "target")))
(if (null? categorised-target-packages-by-system)
'()
(map
(match-lambda
((system . categorised-target-builds)
(let ((categorised-base-builds
(assoc-ref categorised-base-packages-by-system
system)))
(cons
system
(map (lambda (side)
(cons side
(map (lambda (status)
(cons status
(length
(or
(assoc-ref
(if (eq? side 'base)
categorised-base-builds
categorised-target-builds)
status)
'()))))
'(succeeding failing blocked unknown))))
'(base target))))))
(sort
(append categorised-target-packages-by-system
(filter-map
(lambda (system)
(if (assoc-ref categorised-target-packages-by-system
system)
#f
(cons system '())))
all-systems))
(lambda (a b)
(< (or (list-index
(lambda (s)
(string=? (car a) s))
all-systems)
10)
(or (list-index
(lambda (s)
(string=? (car b) s))
all-systems)
10))))))))
|