bugs: update-bug-database!: Do not use get-bugs.
[software/mumi.git] / mumi / bugs.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
3 ;;;
4 ;;; This program is free software: you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Affero General Public License
6 ;;; as published by the Free Software Foundation, either version 3 of
7 ;;; the License, or (at your option) any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Affero General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Affero General Public
15 ;;; License along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 (define-module (mumi bugs)
19 #:use-module (mumi config)
20 #:use-module (mumi debbugs)
21 #:use-module (debbugs)
22 #:use-module (sqlite3)
23 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-11)
25 #:use-module (srfi srfi-26)
26 #:use-module (ice-9 rdelim)
27 #:use-module (ice-9 format)
28 #:export (db-create!
29 update-bug-database!
30
31 bugs-by-tag
32 bugs-by-severity
33 bugs-by-status
34 bugs-by-submitter
35 bugs-by-owner))
36
37 \f
38 ;; This procedure and the following two macros have been taken from
39 ;; Cuirass.
40 (define (%sqlite-exec db sql . args)
41 "Evaluate the given SQL query with the given ARGS. Return the list of
42 rows."
43 (define (normalize arg)
44 ;; Turn ARG into a string, unless it's a primitive SQL datatype.
45 (if (or (null? arg) (pair? arg) (vector? arg))
46 (object->string arg)
47 arg))
48
49 (let ((stmt (sqlite-prepare db sql #:cache? #t)))
50 (for-each (lambda (arg index)
51 (sqlite-bind stmt index (normalize arg)))
52 args (iota (length args) 1))
53 (let ((result (sqlite-fold-right cons '() stmt)))
54 (sqlite-finalize stmt)
55 result)))
56
57 (define-syntax sqlite-exec/bind
58 (lambda (s)
59 ;; Expand to an '%sqlite-exec' call where the query string has
60 ;; interspersed question marks and the argument list is separate.
61 (define (string-literal? s)
62 (string? (syntax->datum s)))
63
64 (syntax-case s ()
65 ((_ db (bindings ...) tail str arg rest ...)
66 #'(sqlite-exec/bind db
67 (bindings ... (str arg))
68 tail
69 rest ...))
70 ((_ db (bindings ...) tail str)
71 #'(sqlite-exec/bind db (bindings ...) str))
72 ((_ db ((strings args) ...) tail)
73 (and (every string-literal? #'(strings ...))
74 (string-literal? #'tail))
75 ;; Optimized case: only string literals.
76 (with-syntax ((query (string-join
77 (append (syntax->datum #'(strings ...))
78 (list (syntax->datum #'tail)))
79 "? ")))
80 #'(%sqlite-exec db query args ...)))
81 ((_ db ((strings args) ...) tail)
82 ;; Fallback case: some of the strings aren't literals.
83 #'(%sqlite-exec db (string-join (list strings ... tail) "? ")
84 args ...)))))
85
86 (define-syntax-rule (sqlite-exec db query args ...)
87 "Execute the specific QUERY with the given ARGS. Uses of 'sqlite-exec'
88 typically look like this:
89
90 (sqlite-exec db \"SELECT * FROM Foo WHERE x = \"
91 x \"AND Y=\" y \";\")
92
93 References to variables 'x' and 'y' here are replaced by question marks in the
94 SQL query, and then 'sqlite-bind' is used to bind them.
95
96 This ensures that (1) SQL injection is impossible, and (2) the number of
97 question marks matches the number of arguments to bind."
98 (sqlite-exec/bind db () "" query args ...))
99
100 (define (last-insert-rowid db)
101 (vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
102 0))
103
104 (define %db-name
105 (string-append (%config 'db-dir) "/bugs.db"))
106
107 (define* (with-db proc #:key write?)
108 (let ((db (sqlite-open %db-name (logior (if write?
109 SQLITE_OPEN_READWRITE
110 SQLITE_OPEN_READONLY)
111 SQLITE_OPEN_NOMUTEX))))
112 (dynamic-wind
113 (const #t)
114 (lambda ()
115 (proc db))
116 (lambda () (sqlite-close db)))))
117
118 (define (read-sql-file file-name)
119 "Return a list of string containing SQL instructions from FILE-NAME."
120 (call-with-input-file file-name
121 (lambda (port)
122 (let loop ((insts '()))
123 (let ((inst (read-delimited ";" port 'concat)))
124 (if (or (eof-object? inst)
125 ;; Don't cons the spaces after the last instructions.
126 (string-every char-whitespace? inst))
127 (reverse! insts)
128 (loop (cons inst insts))))))))
129
130 (define (db-load db schema)
131 "Evaluate the file SCHEMA, which may contain SQL queries, into DB."
132 (for-each (cut sqlite-exec db <>)
133 (read-sql-file schema)))
134
135 (define (db-create!)
136 (unless (file-exists? %db-name)
137 (let ((db (sqlite-open %db-name (logior SQLITE_OPEN_CREATE
138 SQLITE_OPEN_READWRITE
139 SQLITE_OPEN_NOMUTEX))))
140 (db-load db (string-append (%config 'pkg-dir) "/schema.sql"))
141 db)))
142
143 \f
144 (define (add-bug! id submitter owner status severity tags)
145 "Record a new bug with the given fields, or update an existing
146 record."
147 (let ((tag-string
148 (if tags (string-append "|"
149 (string-join (string-split tags #\space) "|" 'suffix))
150 "")))
151 (with-db (lambda (db)
152 (sqlite-exec db
153 "INSERT INTO bugs (id, submitter, owner, status, severity, tags) VALUES ("
154 id "," submitter "," owner "," status "," severity "," tag-string
155 ") ON CONFLICT(id) DO UPDATE SET \
156 status=excluded.status,\
157 submitter=excluded.submitter,\
158 owner=excluded.owner,\
159 severity=excluded.severity,\
160 tags=excluded.tags;")
161 (last-insert-rowid db))
162 #:write? #t)))
163
164 (define (bugs-by-status status)
165 "Return all bug ids with the given STATUS."
166 (map (cut vector-ref <> 0)
167 (with-db
168 (lambda (db)
169 (sqlite-exec db
170 "SELECT id FROM bugs WHERE status = " status ";")))))
171
172 (define (bugs-by-severity severity)
173 "Return all bug ids with the given SEVERITY."
174 (map (cut vector-ref <> 0)
175 (with-db
176 (lambda (db)
177 (sqlite-exec db
178 "SELECT id FROM bugs WHERE severity = " severity ";")))))
179
180 (define (bugs-by-submitter submitter)
181 "Return all bug ids with the given SUBMITTER."
182 (map (cut vector-ref <> 0)
183 (with-db
184 (lambda (db)
185 (sqlite-exec db
186 "SELECT id FROM bugs WHERE submitter LIKE "
187 (string-append "%" submitter "%") ";")))))
188
189 (define (bugs-by-owner owner)
190 "Return all bug ids with the given OWNER."
191 (map (cut vector-ref <> 0)
192 (with-db
193 (lambda (db)
194 (sqlite-exec db
195 "SELECT id FROM bugs WHERE owner LIKE "
196 (string-append "%" owner "%") ";")))))
197
198 (define (bugs-by-tag tag)
199 "Return all bug ids that match the given TAG."
200 (map (cut vector-ref <> 0)
201 (with-db
202 (lambda (db)
203 (sqlite-exec db
204 "SELECT id FROM bugs WHERE tags LIKE "
205 (string-append "%|" tag "|%") ";")))))
206
207 (define (bug-ids)
208 "Return all bug ids."
209 (map (cut vector-ref <> 0)
210 (with-db
211 (lambda (db)
212 (sqlite-exec db "SELECT id FROM bugs;")))))
213
214 (define* (update-bug-database! #:optional bug-nums)
215 (define chunk-size 400)
216 (define (safe-split lst n)
217 (catch #t
218 (lambda ()
219 (split-at lst n))
220 (lambda _
221 (values lst '()))))
222 (let* ((packages (%config 'packages))
223 (bug-nums (or bug-nums
224 (apply lset-adjoin =
225 (append (extract-bug-numbers packages)
226 (extract-bug-numbers packages #:archived? #t))
227 (bug-ids))))
228 (total (length bug-nums)))
229 (display "updating bug database...")
230 ;; Process bugs in chunks
231 (let loop ((lst bug-nums))
232 (let-values (((chunk tail) (safe-split lst chunk-size)))
233 (let ((bugs (soap-invoke* (%config 'debbugs) get-status chunk)))
234 (for-each (lambda (bug)
235 (add-bug! (bug-num bug)
236 (bug-originator bug)
237 (bug-owner bug)
238 (cond
239 ((bug-done bug) "done")
240 (else "open"))
241 (bug-severity bug)
242 (bug-tags bug)))
243 bugs)
244 (let* ((done (- total (length tail)))
245 (ratio (/ done total)))
246 (if (eq? done total)
247 (display "100%!" (current-error-port))
248 (format (current-error-port)
249 "~,1f%..." (exact->inexact (* 100 ratio))))))
250 (if (null? tail) (newline (current-error-port)) (loop tail))))))