messages: Implement search with mu.

* mumi/messages.scm (search-bugs): Use mu to find messages according
to the query, then filter by message sets from the local database.
(ago, date-term->epoch-seconds): Remove procedures.
(punctuation?): New procedure.
(process-query): Remove handling of attributes; replace filters with
sets; build up mu query and use local database for bug sets.
* mumi/web/controller.scm (controller): Adjust call of search-bugs.

diff --git a/mumi/messages.scm b/mumi/messages.scm
index 6ccad33726b06d201cf3437a20d104002bae5ba1..63f68df9aeaeae107cb589689ad012e475e740bb 100644 (file)
--- a/mumi/messages.scm
+++ b/mumi/messages.scm
@@ -196,19 +196,17 @@ result for a while."
                                 (_ #f)))))
                         msg-nums)))))))
 
                                 (_ #f)))))
                         msg-nums)))))))
 

-(define* (search-bugs query #:key (attributes '()) (max 100))
-  "Return a list of all bugs matching the given QUERY string."
-  (let* ((matches (soap-invoke* (%config 'debbugs)
-                                search-est
-                                query
-                                #:max max
-                                #:attributes
-                                (append attributes
-                                        '((package string-prefix "guix")))))
-         (ids (filter-map (lambda (item)
-                            (assoc-ref item "id"))
-                          matches)))
-    (status-with-cache ids)))
+(define* (search-bugs query #:key (sets '()) (max 100))
+  "Return a list of all bugs matching the given QUERY string.
+Interset the result with the id sets in the list SETS."
+  (let* ((ids (delete-duplicates
+               (map (compose string->number mu:bugid)
+                    (mu:message-list query))))
+         (filtered (match sets
+                     (() ids)
+                     (_ (apply lset-intersection eq? ids sets)))))
+    (status-with-cache (if (> (length filtered) max)
+                           (take filtered max) filtered))))

 
 ;; TODO: This returns *any* matching debbugs bug, even if it is not
 ;; part of the default packages.
 
 ;; TODO: This returns *any* matching debbugs bug, even if it is not
 ;; part of the default packages.


@@ -241,125 +239,68 @@ result for a while."
                   severity-ids)))
     (status-with-cache ids)))
 
                   severity-ids)))
     (status-with-cache ids)))
 

-(define (ago unit amount)
-  "Return the point in time that lies AMOUNT UNITs in the past."
-  (let ((amount* (match unit
-                   ('hours amount)
-                   ('days (* 24 amount))
-                   ('weeks (* 24 7 amount))
-                   ('months (* 24 30 amount))
-                   ('years (* 24 365 amount)))))
-    (subtract-duration (date->time-utc (current-date))
-                       (make-time time-duration 0 (* 60 60 amount*)))))
-
-(define (date-term->epoch-seconds term)
-  "Convert a date search term string into seconds since the epoch, or
-return #F if the term is invalid."
-  (match term
-    ("now" 'now)
-    ("today" (time-second (ago 'days 1)))
-    ("yesterday" (time-second (ago 'days 2)))
-    (_
-     (cond
-      ;; TODO: support more date template strings
-      ((or (false-if-exception (string->date term "~Y~m~d"))
-           (false-if-exception (string->date term "~Y-~m-~d")))
-       => (lambda (date)
-            (time-second (date->time-utc date))))
-      ;; e.g. "12h" meaning "12 hours ago"
-      ((string->number (string-drop-right term 1))
-       => (lambda (amount)
-            (match (string-take-right term 1)
-              ("h"
-               (time-second (ago 'hours amount)))
-              ("d"
-               (time-second (ago 'days amount)))
-              ("w"
-               (time-second (ago 'weeks amount)))
-              ("m"
-               (time-second (ago 'months amount)))
-              ("y"
-               (time-second (ago 'years amount)))
-              (_ #f))))
-      (else #f)))))
+(define punctuation?
+  (cut char-set-contains? char-set:punctuation <>))

 
 (define-public (process-query query)
 
 (define-public (process-query query)

-  "Process the QUERY string and return two values: the remaining
-unprocessed query string and an alist of search attributes."
+  "Process the QUERY string and return a list of query terms and
+sets that need to overlap the result set."
+  ;; Mu doesn't like punctuation.  Replace with spaces.
+  (define (clean-term term)
+    (string-map (match-lambda
+                  ((? punctuation? c) #\space)
+                  (c c))
+                term))

   (fold (lambda (term acc)
           (match acc
             ((#:terms terms
   (fold (lambda (term acc)
           (match acc
             ((#:terms terms

-              #:attributes attrs
-              #:filters fs)
+              #:sets fs)

              (match (string-split term #\:)
                ;; This is not supported by the Debbugs SOAP service,
                ;; so we filter locally.
                (("is" (or "done" "closed"))
                 `(#:terms ,terms
              (match (string-split term #\:)
                ;; This is not supported by the Debbugs SOAP service,
                ;; so we filter locally.
                (("is" (or "done" "closed"))
                 `(#:terms ,terms

-                  #:attributes ,attrs
-                  #:filters
-                  ,(cons bug-done fs)))
+                  #:sets ,(cons (db:bugs-by-status "done") fs)))

                (("is" (or "open" "pending"))
                 `(#:terms ,terms
                (("is" (or "open" "pending"))
                 `(#:terms ,terms

-                  #:attributes ,attrs
-                  #:filters
-                  ,(cons (negate bug-done) fs)))
-               ;; "date" for submission date, "mdate" for message date.
-               (((and (or "date" "mdate") type) when)
-                (let ((date-attribute (match type
-                                        ("date" 'date)
-                                        ("mdate" '@cdate)))
-                      (pat "(yesterday|today|now|[1-9][0-9]*(h|d|w|m|y)|[0-9]+)"))
-                  (or (match (map (compose date-term->epoch-seconds
-                                           match:substring)
-                                  (list-matches pat when))
-                        ((and ((? number? start)
-                               (? number? end))
-                              range)
-                         (match (sort range <)
-                           ((start end)
-                            `(#:terms ,terms
-                              #:attributes ,(cons `(,date-attribute >< ,start ,end) attrs)
-                              #:filters ,fs))))
-                        ((or ('now (? number? since))
-                             ((? number? since) 'now))
-                         `(#:terms ,terms
-                           #:attributes ,(cons `(,date-attribute > ,since) attrs)
-                           #:filters ,fs))
-                        (_ #f))
-                      ;; Invalid, don't do anything.
-                      `(#:terms ,terms
-                        #:attributes ,attrs
-                        #:filters ,fs))))
+                  #:sets ,(cons (db:bugs-by-status "open") fs)))
+               (("date" when)
+                `(#:terms ,(cons (string-append "date:" when) terms)
+                  #:sets ,fs))
+               ;; TODO: this should only be the title of the bug, not
+               ;; the subject.

                (("title" title)
                (("title" title)

-                `(#:terms ,terms
-                  #:attributes ,(cons `(subject string-contains ,title) attrs)
-                  #:filters ,fs))
+                `(#:terms
+                  ,(cons (string-append "subject:" (clean-term title))
+                         terms)
+                  #:sets ,fs))
+               (("subject" subject)
+                `(#:terms
+                  ,(cons (string-append "subject:" (clean-term subject))
+                         terms)
+                  #:sets ,fs))

                (("tag" tag)
                 `(#:terms ,terms
                (("tag" tag)
                 `(#:terms ,terms

-                  #:attributes ,(cons `(tags string= ,tag) attrs)
-                  #:filters ,fs))
+                  #:sets
+                  ,(cons (db:bugs-by-tag (clean-term tag)) fs)))

                (("author" who)
                (("author" who)

+                `(#:terms
+                  ,(cons (string-append "from:" (clean-term who)) terms)
+                  #:sets ,fs))
+               (("owner" who)

                 `(#:terms ,terms
                 `(#:terms ,terms

-                  #:attributes ,(cons `(@author string-contains ,who) attrs)
-                  #:filters ,fs))
-               ;; This is not supported by the Debbugs SOAP service,
-               ;; so we filter locally.  At least we know that we need
-               ;; bugs where the author is "who".
+                  #:sets ,(cons (db:bugs-by-owner who) fs)))

                (("submitter" who)
                 `(#:terms ,terms
                (("submitter" who)
                 `(#:terms ,terms

-                  #:attributes ,(cons `(@author string-contains ,who) attrs)
-                  #:filters ,(cons (lambda (bug)
-                                     (string-contains-ci (bug-originator bug)
-                                                         who))
-                                   fs)))
+                  #:sets ,(cons (db:bugs-by-submitter who) fs)))

                (("severity" level)
                 `(#:terms ,terms
                (("severity" level)
                 `(#:terms ,terms

-                  #:attributes ,(cons `(severity string= ,level) attrs)
-                  #:filters ,fs))
+                  #:sets ,(cons (db:bugs-by-severity level) fs)))
+               ((whatever term)
+                `(#:terms ,(cons (clean-term term) terms)
+                  #:sets ,fs))

                (_
                (_

-                `(#:terms ,(cons term terms)
-                  #:attributes ,attrs
-                  #:filters ,fs))))))
-        '(#:terms () #:attributes () #:filters ())
+                `(#:terms ,(cons (clean-term term) terms)
+                  #:sets ,fs))))))
+        '(#:terms () #:sets ())

         (string-tokenize query)))
         (string-tokenize query)))

diff --git a/mumi/web/controller.scm b/mumi/web/controller.scm
index 7f0d9d59cf478292f0b387895322855515902c61..e8548232ea0fed7d5d527dafe67b09a236592a90 100644 (file)
--- a/mumi/web/controller.scm
+++ b/mumi/web/controller.scm
@@ -81,23 +81,9 @@
             (list-of-matching-bugs query
                                    (match (process-query query)
                                      ((#:terms terms
             (list-of-matching-bugs query
                                    (match (process-query query)
                                      ((#:terms terms

-                                       #:attributes attrs
-                                       #:filters '())
+                                       #:sets s)

                                       (search-bugs (string-join terms)
                                       (search-bugs (string-join terms)

-                                                   #:attributes attrs))
-                                     ;; Fetch more messages if there
-                                     ;; are local filters to increase
-                                     ;; the chance of finding some
-                                     ;; that pass the filter.
-                                     ((#:terms terms
-                                       #:attributes attrs
-                                       #:filters fs)
-                                      (let ((str (string-join terms)))
-                                        (filter (lambda (bug)
-                                                  (every (lambda (f) (f bug)) fs))
-                                                (search-bugs (string-join terms)
-                                                             #:attributes attrs
-                                                             #:max 800)))))))
+                                                   #:sets s)))))

           `(p "Could not search for " (strong ,query) "."))))))
     (('GET "issue" (? string->number id))
      (render-with-error-handling
           `(p "Could not search for " (strong ,query) "."))))))
     (('GET "issue" (? string->number id))
      (render-with-error-handling