mumi: Add bugs.
authorRicardo Wurmus <rekado@elephly.net>
Thu, 12 Mar 2020 09:56:47 +0000 (10:56 +0100)
committerRicardo Wurmus <rekado@elephly.net>
Thu, 12 Mar 2020 09:56:47 +0000 (10:56 +0100)
* mumi/bugs.scm: New file.
* etc/schema.sql: New file.
* Makefile.am (SOURCES): Add mumi/bugs.scm.
(dist_pkgdata_DATA): Add etc/schema.sql.

Makefile.am
etc/schema.sql [new file with mode: 0644]
mumi/bugs.scm [new file with mode: 0644]

index 2a07fae..fa4e149 100644 (file)
@@ -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 (file)
index 0000000..4bcecda
--- /dev/null
@@ -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 (file)
index 0000000..ef4a6bf
--- /dev/null
@@ -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))
+
+\f
+;; 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)))
+
+\f
+(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))))))