diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | configure.ac | 5 | ||||
| -rw-r--r-- | guix.scm | 1 | ||||
| -rw-r--r-- | mumi/bugs.scm | 249 | ||||
| -rw-r--r-- | mumi/messages.scm | 13 | ||||
| -rw-r--r-- | scripts/mumi.in | 8 |
6 files changed, 4 insertions, 273 deletions
diff --git a/Makefile.am b/Makefile.am index 9426c26..82add7b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -44,7 +44,6 @@ SOURCES = \ mumi/web/util.scm \ mumi/web/view/html.scm \ mumi/web/view/utils.scm \ - mumi/bugs.scm \ mumi/cache.scm \ mumi/messages.scm \ mumi/jobs.scm \ diff --git a/configure.ac b/configure.ac index bdf2a42..74e937c 100644 --- a/configure.ac +++ b/configure.ac @@ -21,11 +21,6 @@ if test "x$have_guile_email" != "xyes"; then AC_MSG_ERROR([guile-email is missing; please install it.]) fi -GUILE_MODULE_AVAILABLE([have_guile_sqlite3], [(sqlite3)]) -if test "x$have_guile_sqlite3" != "xyes"; then - AC_MSG_ERROR([Guile-Sqlite3 is missing; please install it.]) -fi - GUILE_MODULE_AVAILABLE([have_mailutils], [(mailutils mailutils)]) if test "x$have_mailutils" != "xyes"; then AC_MSG_ERROR([Mailutils is missing; please install it.]) @@ -48,7 +48,6 @@ (package-arguments guile-fibers) ((#:tests? _ #f) #f))))) ("guile-redis" ,guile-redis) - ("guile-sqlite3" ,guile-sqlite3) ("guile-syntax-highlight" ,guile-syntax-highlight) ("guile-xapian" ,guile-xapian) ("guile-webutils" ,guile-webutils) diff --git a/mumi/bugs.scm b/mumi/bugs.scm deleted file mode 100644 index ea85ca2..0000000 --- a/mumi/bugs.scm +++ /dev/null @@ -1,249 +0,0 @@ -;;; 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 (mumi 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 LIKE " - (string-append "%" 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 LIKE " - (string-append "%" 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 (bug-ids) - "Return all bug ids." - (map (cut vector-ref <> 0) - (with-db - (lambda (db) - (sqlite-exec db "SELECT id FROM bugs;"))))) - -(define* (update-bug-database! #:optional bug-nums) - (define chunk-size 400) - (define (safe-split lst n) - (catch #t - (lambda () - (split-at lst n)) - (lambda _ - (values lst '())))) - (let* ((packages (%config 'packages)) - (bug-nums (or bug-nums - (apply lset-adjoin = - (append (extract-bug-numbers packages) - (extract-bug-numbers packages #:archived? #t)) - (bug-ids)))) - (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 (map bug-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)))))) diff --git a/mumi/messages.scm b/mumi/messages.scm index 7efd74e..538c0de 100644 --- a/mumi/messages.scm +++ b/mumi/messages.scm @@ -31,7 +31,6 @@ #:use-module (mumi config) #:use-module (mumi debbugs) #:use-module (mumi xapian) - #:use-module ((mumi bugs) #:prefix db:) #:use-module (web client) #:export (search-bugs fetch-bug @@ -224,17 +223,13 @@ about." (define (easy-bugs) "Return all bugs that have been tagged \"easy\"." - (let ((ids (db:bugs-by-tag "easy"))) - (status-with-cache ids))) + (search-bugs "tag:easy")) (define* (bugs-by-severity severity #:optional status) "Return severe bugs." - (let* ((severity-ids (db:bugs-by-severity severity)) - (ids (if status - (let ((status-ids (db:bugs-by-status status))) - (lset-intersection eq? severity-ids status-ids)) - severity-ids))) - (status-with-cache ids))) + (search-bugs (if status + (format #f "severity:~a status:~a" severity status) + (format #f "severity:~a" severity)))) (define punctuation? (cut char-set-contains? char-set:punctuation <>)) diff --git a/scripts/mumi.in b/scripts/mumi.in index 67dad78..2d4b28f 100644 --- a/scripts/mumi.in +++ b/scripts/mumi.in @@ -29,8 +29,6 @@ (mumi config) ((mumi debbugs) #:select (extract-bug-numbers)) - ((mumi bugs) - #:select (db-create! update-bug-database!)) ((mumi jobs) #:select (worker-loop)) ((mumi web server) @@ -38,8 +36,6 @@ ((mumi xapian) #:select (index!))) -(db-create!) - (define %default-repl-server-port ;; Default port to run REPL server on, if --listen-repl is provided ;; but no port is mentioned @@ -58,10 +54,6 @@ (display "Starting full indexing." (current-error-port)) (newline (current-error-port))) (index! #:full? (zero? count)) - (let* ((packages (%config 'packages)) - (nums (append (extract-bug-numbers packages) - (extract-bug-numbers packages #:archived? #t)))) - (update-bug-database! nums)) (and loop? (begin (format (current-error-port) |