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
|
(define-module (guix-qa-frontpage view branch)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (guix-qa-frontpage manage-builds)
#:use-module (guix-qa-frontpage derivation-changes)
#:use-module (guix-qa-frontpage view util)
#:export (branch-view))
(define (branch-view branch change-details derivation-changes-counts)
(define* (package-derivations-comparison-link system
#:key build-change)
(let ((revisions
(assoc-ref change-details "revisions")))
(string-append
(simple-format #f "https://data.qa.guix.gnu.org/compare/package-derivations?base_commit=~A&target_commit=~A&system=~A&target=none"
(assoc-ref (assoc-ref revisions "base")
"commit")
(assoc-ref (assoc-ref revisions "target")
"commit")
system)
(if build-change
(simple-format #f "&build_change=~A" build-change)
""))))
(layout
#:title (simple-format #f "Branch ~A" branch)
#:body
`((main
(div
(table
(@ (style "border-collapse: collapse;"))
(thead
(tr
(th (@ (rowspan 3)) "System")
(th (@ (colspan 8)) "Package build status")
(th))
(tr
(th (@ (colspan 4)) "Base")
(th (@ (colspan 4)
(style "border-left-width: 0.1em; border-left-style: solid; border-left-color: black"))
"With branch changes")
(th))
(tr
,@(let ((header-style
"font-size: 80%; min-width: 3.5rem;"))
`((th (@ (style ,header-style))
"Succeeding")
(th (@ (style ,header-style))
"Failing")
(th (@ (style ,header-style))
"Blocked")
(th (@ (style ,header-style))
"Unknown")
(th (@ (style
,(string-append
header-style
" border-left-width: 0.125em; border-left-style: solid; border-left-color: black;")))
"Succeeding")
(th (@ (style ,header-style))
"Failing")
(th (@ (style ,header-style))
"Blocked")
(th (@ (style ,header-style))
"Unknown")
(th)))))
(tbody
,@(if derivation-changes-counts
(if (null? derivation-changes-counts)
`((tr
(td (@ (colspan 7))
"No package derivation changes")))
(map
(match-lambda
((system . counts)
(define (count side status)
(assoc-ref (assoc-ref
counts
side)
status))
`(tr
(td (@ (class "monospace")) ,system)
,@(map (lambda (status)
`(td ,(count 'base status)))
'(succeeding failing blocked unknown))
(td ,@(if (and (>= (count 'target 'succeeding)
(count 'base 'succeeding))
(> (count 'target 'succeeding)
0))
`((@ (class "good")))
'())
,(count 'target 'succeeding))
,(if (> (count 'target 'failing)
(count 'base 'failing))
`(td (@ (class "bad"))
,(count 'target 'failing))
`(td ,(count 'target 'failing)))
,(if (> (count 'target 'blocked)
(count 'base 'blocked))
`(td (@ (class "bad"))
,(count 'target 'blocked))
`(td ,(count 'target 'blocked)))
,(if (> (count 'target 'unknown)
(count 'base 'unknown))
`(td (@ (class "bad"))
,(count 'target 'unknown))
`(td ,(count 'target 'unknown)))
(td (a (@ (href
,(package-derivations-comparison-link system)))
"View comparison")))))
derivation-changes-counts))
'((tr
(td (@ (colspan 7))
"Comparison unavailable")))))))))))
|