blob: 1c5f52d34d582d52e1cf277a54303257b8ef595c (
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
|
;;; 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 issue)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (guix-qa-frontpage manage-builds)
#:use-module (guix-qa-frontpage derivation-changes)
#:export (%overall-statuses
status-index
issue-patches-overall-status))
(define good-status 'important-checks-passing)
(define bad-status 'important-checks-failing)
(define needs-looking-at-status 'needs-looking-at)
(define unknown-status 'unknown)
(define %overall-statuses
(list good-status
unknown-status
needs-looking-at-status
bad-status))
(define (status-index status)
(list-index (lambda (s)
(eq? s status))
%overall-statuses))
(define (worst-status statuses)
(list-ref %overall-statuses
(apply max (map status-index statuses))))
(define (issue-patches-overall-status derivation-changes mumi-tags)
(define %systems-to-consider
'("x86_64-linux"
;; "i686-linux" disabled while resolving bordeaux build issues
"aarch64-linux"
"armhf-linux"))
(define builds-status
(let* ((base-builds
(builds-by-system-excluding-cross-builds
derivation-changes "base"))
(target-builds
(builds-by-system-excluding-cross-builds
derivation-changes "target"))
(all-systems
(delete-duplicates
(append (map car base-builds)
(map car target-builds))))
(categorised-base-builds-by-system
(categorise-builds all-systems base-builds))
(categorised-target-builds-by-system
(categorise-builds all-systems target-builds)))
(if (builds-missing-for-derivation-changes? derivation-changes)
unknown-status
(if (null? target-builds)
good-status
(worst-status
(map
(match-lambda
((system . categorised-target-builds)
(let ((categorised-base-builds
(assoc-ref categorised-base-builds-by-system
system)))
(define (count side status)
(length
(assoc-ref
(if (eq? side 'base)
categorised-base-builds
categorised-target-builds)
status)))
(let ((base-failure-count (count 'base 'failing))
(target-failure-count (count 'target 'failing)))
(if (and (<= target-failure-count
base-failure-count)
(= (count 'target 'unknown) 0))
good-status
(if (= (count 'target 'unknown) 0)
(let ((unblocked-builds
(- (count 'base 'blocked)
(count 'target 'blocked)))
(new-failures
(- target-failure-count
base-failure-count)))
(if (>= unblocked-builds
new-failures)
needs-looking-at-status
bad-status))
unknown-status))))))
(filter
(lambda (builds-by-system)
(member (car builds-by-system)
%systems-to-consider))
categorised-target-builds-by-system)))))))
(define tags-status
(if (member "moreinfo" mumi-tags)
needs-looking-at-status
good-status))
(let ((overall-status
(worst-status (list builds-status
tags-status))))
overall-status))
|