;;; mumi -- Mediocre, uh, mail interface ;;; Copyright © 2020 Ricardo Wurmus ;;; ;;; 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 ;;; . (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 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!) (define chunk-size 400) (define (safe-split lst n) (catch #t (lambda () (split-at lst n)) (lambda _ (values lst '())))) (let* ((bug-nums (apply lset-adjoin = (append-map (lambda (package) (soap-invoke (%config 'debbugs) get-bugs `((package . ,package)))) (%config 'packages)) (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 (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))))))