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