summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile.am3
-rw-r--r--etc/schema.sql14
-rw-r--r--mumi/bugs.scm239
3 files changed, 256 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am
index 2a07fae..fa4e149 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -33,6 +33,8 @@ assetscss_DATA = $(wildcard assets/css/*)
assetsimg_DATA = $(wildcard assets/img/*)
assetsjs_DATA = $(wildcard assets/js/*)
+dist_pkgdata_DATA = etc/schema.sql
+
SOURCES = \
mumi/web/download.scm \
mumi/web/server.scm \
@@ -42,5 +44,6 @@ SOURCES = \
mumi/web/util.scm \
mumi/web/view/html.scm \
mumi/web/view/utils.scm \
+ mumi/bugs.scm \
mumi/messages.scm \
mumi/config.scm
diff --git a/etc/schema.sql b/etc/schema.sql
new file mode 100644
index 0000000..4bcecda
--- /dev/null
+++ b/etc/schema.sql
@@ -0,0 +1,14 @@
+BEGIN TRANSACTION;
+
+CREATE TABLE bugs (
+ id INTEGER NOT NULL PRIMARY KEY UNIQUE,
+ submitter TEXT NOT NULL,
+ owner TEXT,
+ severity TEXT NOT NULL,
+ status TEXT NOT NULL,
+ tags TEXT NOT NULL
+);
+
+CREATE INDEX bugs_index ON bugs(id, submitter, owner, severity, status, tags);
+
+COMMIT;
diff --git a/mumi/bugs.scm b/mumi/bugs.scm
new file mode 100644
index 0000000..ef4a6bf
--- /dev/null
+++ b/mumi/bugs.scm
@@ -0,0 +1,239 @@
+;;; mumi -- Mediocre, uh, mail interface
+;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.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 (mumi bugs)
+ #:use-module (mumi config)
+ #:use-module (debbugs)
+ #:use-module (sqlite3)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 format)
+ #:export (db-create!
+ update-bug-database!
+
+ bugs-by-tag
+ bugs-by-severity
+ bugs-by-status
+ bugs-by-submitter
+ bugs-by-owner))
+
+
+;; This procedure and the following two macros have been taken from
+;; Cuirass.
+(define (%sqlite-exec db sql . args)
+ "Evaluate the given SQL query with the given ARGS. Return the list of
+rows."
+ (define (normalize arg)
+ ;; Turn ARG into a string, unless it's a primitive SQL datatype.
+ (if (or (null? arg) (pair? arg) (vector? arg))
+ (object->string arg)
+ arg))
+
+ (let ((stmt (sqlite-prepare db sql #:cache? #t)))
+ (for-each (lambda (arg index)
+ (sqlite-bind stmt index (normalize arg)))
+ args (iota (length args) 1))
+ (let ((result (sqlite-fold-right cons '() stmt)))
+ (sqlite-finalize stmt)
+ result)))
+
+(define-syntax sqlite-exec/bind
+ (lambda (s)
+ ;; Expand to an '%sqlite-exec' call where the query string has
+ ;; interspersed question marks and the argument list is separate.
+ (define (string-literal? s)
+ (string? (syntax->datum s)))
+
+ (syntax-case s ()
+ ((_ db (bindings ...) tail str arg rest ...)
+ #'(sqlite-exec/bind db
+ (bindings ... (str arg))
+ tail
+ rest ...))
+ ((_ db (bindings ...) tail str)
+ #'(sqlite-exec/bind db (bindings ...) str))
+ ((_ db ((strings args) ...) tail)
+ (and (every string-literal? #'(strings ...))
+ (string-literal? #'tail))
+ ;; Optimized case: only string literals.
+ (with-syntax ((query (string-join
+ (append (syntax->datum #'(strings ...))
+ (list (syntax->datum #'tail)))
+ "? ")))
+ #'(%sqlite-exec db query args ...)))
+ ((_ db ((strings args) ...) tail)
+ ;; Fallback case: some of the strings aren't literals.
+ #'(%sqlite-exec db (string-join (list strings ... tail) "? ")
+ args ...)))))
+
+(define-syntax-rule (sqlite-exec db query args ...)
+ "Execute the specific QUERY with the given ARGS. Uses of 'sqlite-exec'
+typically look like this:
+
+ (sqlite-exec db \"SELECT * FROM Foo WHERE x = \"
+ x \"AND Y=\" y \";\")
+
+References to variables 'x' and 'y' here are replaced by question marks in the
+SQL query, and then 'sqlite-bind' is used to bind them.
+
+This ensures that (1) SQL injection is impossible, and (2) the number of
+question marks matches the number of arguments to bind."
+ (sqlite-exec/bind db () "" query args ...))
+
+(define (last-insert-rowid db)
+ (vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
+ 0))
+
+(define %db-name
+ (string-append (%config 'db-dir) "/bugs.db"))
+
+(define* (with-db proc #:key write?)
+ (let ((db (sqlite-open %db-name (logior (if write?
+ SQLITE_OPEN_READWRITE
+ SQLITE_OPEN_READONLY)
+ SQLITE_OPEN_NOMUTEX))))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (proc db))
+ (lambda () (sqlite-close db)))))
+
+(define (read-sql-file file-name)
+ "Return a list of string containing SQL instructions from FILE-NAME."
+ (call-with-input-file file-name
+ (lambda (port)
+ (let loop ((insts '()))
+ (let ((inst (read-delimited ";" port 'concat)))
+ (if (or (eof-object? inst)
+ ;; Don't cons the spaces after the last instructions.
+ (string-every char-whitespace? inst))
+ (reverse! insts)
+ (loop (cons inst insts))))))))
+
+(define (db-load db schema)
+ "Evaluate the file SCHEMA, which may contain SQL queries, into DB."
+ (for-each (cut sqlite-exec db <>)
+ (read-sql-file schema)))
+
+(define (db-create!)
+ (unless (file-exists? %db-name)
+ (let ((db (sqlite-open %db-name (logior SQLITE_OPEN_CREATE
+ SQLITE_OPEN_READWRITE
+ SQLITE_OPEN_NOMUTEX))))
+ (db-load db (string-append (%config 'pkg-dir) "/schema.sql"))
+ db)))
+
+
+(define (add-bug! id submitter owner status severity tags)
+ "Record a new bug with the given fields, or update an existing
+record."
+ (let ((tag-string
+ (if tags (string-append "|"
+ (string-join (string-split tags #\space) "|" 'suffix))
+ "")))
+ (with-db (lambda (db)
+ (sqlite-exec db
+ "INSERT INTO bugs (id, submitter, owner, status, severity, tags) VALUES ("
+ id "," submitter "," owner "," status "," severity "," tag-string
+ ") ON CONFLICT(id) DO UPDATE SET \
+status=excluded.status,\
+submitter=excluded.submitter,\
+owner=excluded.owner,\
+severity=excluded.severity,\
+tags=excluded.tags;")
+ (last-insert-rowid db))
+ #:write? #t)))
+
+(define (bugs-by-status status)
+ "Return all bug ids with the given STATUS."
+ (map (cut vector-ref <> 0)
+ (with-db
+ (lambda (db)
+ (sqlite-exec db
+ "SELECT id FROM bugs WHERE status = " status ";")))))
+
+(define (bugs-by-severity severity)
+ "Return all bug ids with the given SEVERITY."
+ (map (cut vector-ref <> 0)
+ (with-db
+ (lambda (db)
+ (sqlite-exec db
+ "SELECT id FROM bugs WHERE severity = " severity ";")))))
+
+(define (bugs-by-submitter submitter)
+ "Return all bug ids with the given SUBMITTER."
+ (map (cut vector-ref <> 0)
+ (with-db
+ (lambda (db)
+ (sqlite-exec db
+ "SELECT id FROM bugs WHERE submitter = " submitter ";")))))
+
+(define (bugs-by-owner owner)
+ "Return all bug ids with the given OWNER."
+ (map (cut vector-ref <> 0)
+ (with-db
+ (lambda (db)
+ (sqlite-exec db
+ "SELECT id FROM bugs WHERE owner = " owner ";")))))
+
+(define (bugs-by-tag tag)
+ "Return all bug ids that match the given TAG."
+ (map (cut vector-ref <> 0)
+ (with-db
+ (lambda (db)
+ (sqlite-exec db
+ "SELECT id FROM bugs WHERE tags LIKE "
+ (string-append "%|" tag "|%") ";")))))
+
+(define (update-bug-database!)
+ (define chunk-size 400)
+ (define (safe-split lst n)
+ (catch #t
+ (lambda ()
+ (split-at lst n))
+ (lambda _
+ (values lst '()))))
+ (let* ((bug-nums (append-map (lambda (package)
+ (soap-invoke (%config 'debbugs)
+ get-bugs
+ `((package . ,package))))
+ (%config 'packages)))
+ (total (length bug-nums)))
+ (display "updating bug database...")
+ ;; Process bugs in chunks
+ (let loop ((lst bug-nums))
+ (let-values (((chunk tail) (safe-split lst chunk-size)))
+ (let ((bugs (soap-invoke* (%config 'debbugs) get-status chunk)))
+ (for-each (lambda (bug)
+ (add-bug! (bug-num bug)
+ (bug-originator bug)
+ (bug-owner bug)
+ (cond
+ ((bug-done bug) "done")
+ (else "open"))
+ (bug-severity bug)
+ (bug-tags bug)))
+ bugs)
+ (let* ((done (- total (length tail)))
+ (ratio (/ done total)))
+ (if (eq? done total)
+ (display "100%!" (current-error-port))
+ (format (current-error-port)
+ "~,1f%..." (exact->inexact (* 100 ratio))))))
+ (if (null? tail) (newline (current-error-port)) (loop tail))))))
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-19 21:21:35 +0000