mumi/bugs.scm

   1 ;;; mumi -- Mediocre, uh, mail interface
   2 ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
   3 ;;;
   4 ;;; This program is free software: you can redistribute it and/or
   5 ;;; modify it under the terms of the GNU Affero General Public License
   6 ;;; as published by the Free Software Foundation, either version 3 of
   7 ;;; the License, or (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; Affero General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Affero General Public
  15 ;;; License along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 (define-module (mumi bugs)
  19   #:use-module (mumi config)
  20   #:use-module (mumi debbugs)
  21   #:use-module (sqlite3)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-11)
  24   #:use-module (srfi srfi-26)
  25   #:use-module (ice-9 rdelim)
  26   #:use-module (ice-9 format)
  27   #:export (db-create!
  28             update-bug-database!
  29
  30             bugs-by-tag
  31             bugs-by-severity
  32             bugs-by-status
  33             bugs-by-submitter
  34             bugs-by-owner))
  35
  36 \f
  37 ;; This procedure and the following two macros have been taken from
  38 ;; Cuirass.
  39 (define (%sqlite-exec db sql . args)
  40   "Evaluate the given SQL query with the given ARGS.  Return the list of
  41 rows."
  42   (define (normalize arg)
  43     ;; Turn ARG into a string, unless it's a primitive SQL datatype.
  44     (if (or (null? arg) (pair? arg) (vector? arg))
  45         (object->string arg)
  46         arg))
  47
  48   (let ((stmt (sqlite-prepare db sql #:cache? #t)))
  49     (for-each (lambda (arg index)
  50                 (sqlite-bind stmt index (normalize arg)))
  51               args (iota (length args) 1))
  52     (let ((result (sqlite-fold-right cons '() stmt)))
  53       (sqlite-finalize stmt)
  54       result)))
  55
  56 (define-syntax sqlite-exec/bind
  57   (lambda (s)
  58     ;; Expand to an '%sqlite-exec' call where the query string has
  59     ;; interspersed question marks and the argument list is separate.
  60     (define (string-literal? s)
  61       (string? (syntax->datum s)))
  62
  63     (syntax-case s ()
  64       ((_ db (bindings ...) tail str arg rest ...)
  65        #'(sqlite-exec/bind db
  66                            (bindings ... (str arg))
  67                            tail
  68                            rest ...))
  69       ((_ db (bindings ...) tail str)
  70        #'(sqlite-exec/bind db (bindings ...) str))
  71       ((_ db ((strings args) ...) tail)
  72        (and (every string-literal? #'(strings ...))
  73             (string-literal? #'tail))
  74        ;; Optimized case: only string literals.
  75        (with-syntax ((query (string-join
  76                              (append (syntax->datum #'(strings ...))
  77                                      (list (syntax->datum #'tail)))
  78                              "? ")))
  79          #'(%sqlite-exec db query args ...)))
  80       ((_ db ((strings args) ...) tail)
  81        ;; Fallback case: some of the strings aren't literals.
  82        #'(%sqlite-exec db (string-join (list strings ... tail) "? ")
  83                        args ...)))))
  84
  85 (define-syntax-rule (sqlite-exec db query args ...)
  86   "Execute the specific QUERY with the given ARGS.  Uses of 'sqlite-exec'
  87 typically look like this:
  88
  89   (sqlite-exec db \"SELECT * FROM Foo WHERE x = \"
  90                   x \"AND Y=\" y \";\")
  91
  92 References to variables 'x' and 'y' here are replaced by question marks in the
  93 SQL query, and then 'sqlite-bind' is used to bind them.
  94
  95 This ensures that (1) SQL injection is impossible, and (2) the number of
  96 question marks matches the number of arguments to bind."
  97   (sqlite-exec/bind db () "" query args ...))
  98
  99 (define (last-insert-rowid db)
 100   (vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
 101               0))
 102
 103 (define %db-name
 104   (string-append (%config 'db-dir) "/bugs.db"))
 105
 106 (define* (with-db proc #:key write?)
 107   (let ((db (sqlite-open %db-name (logior (if write?
 108                                               SQLITE_OPEN_READWRITE
 109                                               SQLITE_OPEN_READONLY)
 110                                           SQLITE_OPEN_NOMUTEX))))
 111     (dynamic-wind
 112       (const #t)
 113       (lambda ()
 114         (proc db))
 115       (lambda () (sqlite-close db)))))
 116
 117 (define (read-sql-file file-name)
 118   "Return a list of string containing SQL instructions from FILE-NAME."
 119   (call-with-input-file file-name
 120     (lambda (port)
 121       (let loop ((insts '()))
 122         (let ((inst (read-delimited ";" port 'concat)))
 123           (if (or (eof-object? inst)
 124                   ;; Don't cons the spaces after the last instructions.
 125                   (string-every char-whitespace? inst))
 126               (reverse! insts)
 127               (loop (cons inst insts))))))))
 128
 129 (define (db-load db schema)
 130   "Evaluate the file SCHEMA, which may contain SQL queries, into DB."
 131   (for-each (cut sqlite-exec db <>)
 132             (read-sql-file schema)))
 133
 134 (define (db-create!)
 135   (unless (file-exists? %db-name)
 136     (let ((db (sqlite-open %db-name (logior SQLITE_OPEN_CREATE
 137                                             SQLITE_OPEN_READWRITE
 138                                             SQLITE_OPEN_NOMUTEX))))
 139       (db-load db (string-append (%config 'pkg-dir) "/schema.sql"))
 140       db)))
 141
 142 \f
 143 (define (add-bug! id submitter owner status severity tags)
 144   "Record a new bug with the given fields, or update an existing
 145 record."
 146   (let ((tag-string
 147          (if tags (string-append "|"
 148                                  (string-join (string-split tags #\space) "|" 'suffix))
 149              "")))
 150     (with-db (lambda (db)
 151                (sqlite-exec db
 152                             "INSERT INTO bugs (id, submitter, owner, status, severity, tags) VALUES ("
 153                             id "," submitter "," owner "," status "," severity "," tag-string
 154                             ") ON CONFLICT(id) DO UPDATE SET \
 155 status=excluded.status,\
 156 submitter=excluded.submitter,\
 157 owner=excluded.owner,\
 158 severity=excluded.severity,\
 159 tags=excluded.tags;")
 160                (last-insert-rowid db))
 161              #:write? #t)))
 162
 163 (define (bugs-by-status status)
 164   "Return all bug ids with the given STATUS."
 165   (map (cut vector-ref <> 0)
 166        (with-db
 167         (lambda (db)
 168           (sqlite-exec db
 169                        "SELECT id FROM bugs WHERE status = " status ";")))))
 170
 171 (define (bugs-by-severity severity)
 172   "Return all bug ids with the given SEVERITY."
 173   (map (cut vector-ref <> 0)
 174        (with-db
 175         (lambda (db)
 176           (sqlite-exec db
 177                        "SELECT id FROM bugs WHERE severity = " severity ";")))))
 178
 179 (define (bugs-by-submitter submitter)
 180   "Return all bug ids with the given SUBMITTER."
 181   (map (cut vector-ref <> 0)
 182        (with-db
 183         (lambda (db)
 184           (sqlite-exec db
 185                        "SELECT id FROM bugs WHERE submitter LIKE "
 186                        (string-append "%" submitter "%") ";")))))
 187
 188 (define (bugs-by-owner owner)
 189   "Return all bug ids with the given OWNER."
 190   (map (cut vector-ref <> 0)
 191        (with-db
 192         (lambda (db)
 193           (sqlite-exec db
 194                        "SELECT id FROM bugs WHERE owner LIKE "
 195                        (string-append "%" owner "%") ";")))))
 196
 197 (define (bugs-by-tag tag)
 198   "Return all bug ids that match the given TAG."
 199   (map (cut vector-ref <> 0)
 200        (with-db
 201         (lambda (db)
 202           (sqlite-exec db
 203                        "SELECT id FROM bugs WHERE tags LIKE "
 204                        (string-append "%|" tag "|%") ";")))))
 205
 206 (define (bug-ids)
 207   "Return all bug ids."
 208   (map (cut vector-ref <> 0)
 209        (with-db
 210         (lambda (db)
 211           (sqlite-exec db "SELECT id FROM bugs;")))))
 212
 213 (define* (update-bug-database! #:optional bug-nums)
 214   (define chunk-size 400)
 215   (define (safe-split lst n)
 216     (catch #t
 217       (lambda ()
 218         (split-at lst n))
 219       (lambda _
 220         (values lst '()))))
 221   (let* ((packages (%config 'packages))
 222          (bug-nums (or bug-nums
 223                        (apply lset-adjoin =
 224                               (append (extract-bug-numbers packages)
 225                                       (extract-bug-numbers packages #:archived? #t))
 226                               (bug-ids))))
 227          (total (length bug-nums)))
 228     (display "updating bug database...")
 229     ;; Process bugs in chunks
 230     (let loop ((lst bug-nums))
 231       (let-values (((chunk tail) (safe-split lst chunk-size)))
 232         (let ((bugs (map bug-status chunk)))
 233           (for-each (lambda (bug)
 234                       (add-bug! (bug-num bug)
 235                                 (bug-originator bug)
 236                                 (bug-owner bug)
 237                                 (cond
 238                                  ((bug-done bug) "done")
 239                                  (else "open"))
 240                                 (bug-severity bug)
 241                                 (bug-tags bug)))
 242                     bugs)
 243           (let* ((done (- total (length tail)))
 244                  (ratio (/ done total)))
 245             (if (eq? done total)
 246                 (display "100%!" (current-error-port))
 247                 (format (current-error-port)
 248                         "~,1f%..." (exact->inexact (* 100 ratio))))))
 249         (if (null? tail) (newline (current-error-port)) (loop tail))))))