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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
;;; 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 mumi)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (json)
#:use-module (kolam http)
#:use-module (kolam parse)
#:use-module (web uri)
#:use-module (web client)
#:use-module ((guix-data-service utils) #:select (chunk!))
#:use-module ((guix-build-coordinator utils fibers)
#:select (retry-on-error))
#:export (mumi-search-issues
mumi-issue-open?
mumi-bulk-issues))
(define (at-most max-length lst)
"If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
return its MAX-LENGTH first elements and its tail."
(let loop ((len 0)
(lst lst)
(result '()))
(match lst
(()
(values (reverse result) '()))
((head . tail)
(if (>= len max-length)
(values (reverse result) lst)
(loop (+ 1 len) tail (cons head result)))))))
(define %max-cached-connections
;; Maximum number of connections kept in cache by
;; 'open-connection-for-uri/cached'.
16)
(define open-socket-for-uri/cached
(let ((cache '()))
(lambda* (uri #:key fresh? verify-certificate?)
"Return a connection for URI, possibly reusing a cached connection.
When FRESH? is true, delete any cached connections for URI and open a new one.
Return #f if URI's scheme is 'file' or #f.
When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
(define host (uri-host uri))
(define scheme (uri-scheme uri))
(define key (list host scheme (uri-port uri)))
(and (not (memq scheme '(file #f)))
(match (assoc-ref cache key)
(#f
;; Open a new connection to URI and evict old entries from
;; CACHE, if any.
(let ((socket
(open-socket-for-uri
uri
#:verify-certificate? verify-certificate?))
(new-cache evicted
(at-most (- %max-cached-connections 1) cache)))
(for-each (match-lambda
((_ . port)
(false-if-exception (close-port port))))
evicted)
(set! cache (alist-cons key socket new-cache))
socket))
(socket
(if (or fresh? (port-closed? socket))
(begin
(false-if-exception (close-port socket))
(set! cache (alist-delete key cache))
(open-socket-for-uri/cached uri
#:verify-certificate?
verify-certificate?))
(begin
;; Drain input left from the previous use.
(drain-input socket)
socket))))))))
(define (call-with-cached-connection uri proc)
(let ((port (open-socket-for-uri/cached uri)))
(with-throw-handler #t
(lambda ()
(proc port))
(lambda _
(close-port port)))))
(define* (graphql-http-get*
uri document
#:key (verify-certificate? #t)
(port (open-socket-for-uri
uri
#:verify-certificate? verify-certificate?))
(keep-alive? #f)
(variables '()))
(call-with-values
(lambda ()
(let ((response
body
(http-get
(string-append uri
"?query="
(uri-encode (scm->graphql-string document))
"&"
"variables="
(uri-encode (scm->json-string
((@@ (kolam http) variables->alist)
variables))))
#:streaming? #t
#:keep-alive? keep-alive?
#:verify-certificate? verify-certificate?
#:port port)))
(values response
body)))
(@@ (kolam http) graphql-http-response)))
(define (mumi-search-issues query)
(let ((response
(graphql-http-get "https://issues.guix.gnu.org/graphql"
`(document (query (#(issues #:search ,query) number title date open (blocked_by number)))))))
(assoc-ref response
"issues")))
(define (mumi-issue-open? number)
(let ((response
(graphql-http-get "https://issues.guix.gnu.org/graphql"
`(document (query (#(issue #:number ,number) open))))))
(assoc-ref (cdr (first response))
"open")))
(define (mumi-bulk-issues numbers)
(define url
"https://issues.guix.gnu.org/graphql")
(let ((number-to-data
(make-hash-table)))
(for-each
(lambda (chunk)
(let ((response
(retry-on-error
(lambda ()
(call-with-cached-connection
(string->uri url)
(lambda (port)
(graphql-http-get*
url
`(document
,@(map (lambda (number)
`(query (#(issue #:number ,number)
number title open severity tags
(merged_with number))))
chunk))
#:keep-alive? #t
#:port port))))
#:times 1
#:delay 0)))
(for-each
(lambda (res)
(let ((data (cdr res)))
(hash-set! number-to-data
(assoc-ref data "number")
`((title . ,(assoc-ref data "title"))
(open? . ,(assoc-ref data "open"))
(tags . ,(vector->list
(assoc-ref data "tags")))
(merged-with . ,(map
(lambda (data)
(assoc-ref data "number"))
(vector->list
(assoc-ref data "merged_with"))))
(severity . ,(assoc-ref data "severity"))))))
response)))
(chunk! (list-copy numbers) 30))
(map (lambda (number)
(hash-ref number-to-data number))
numbers)))
|