summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am1
-rw-r--r--configure.ac5
-rw-r--r--guix.scm1
-rw-r--r--mumi/bugs.scm249
-rw-r--r--mumi/messages.scm13
-rw-r--r--scripts/mumi.in8
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.])
diff --git a/guix.scm b/guix.scm
index 3d6949f..cbc5e66 100644
--- a/guix.scm
+++ b/guix.scm
@@ -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)