process-query: Support date filtering.

* mumi/messages.scm (ago, date-term->epoch-seconds): New procedures.
(process-query): Support "date" and "mdate" queries.

1 files changed, 69 insertions, 0 deletions

diff --git a/mumi/messages.scm b/mumi/messages.scm
index 00f80fd..5110de9 100644
--- a/mumi/messages.scm
+++ b/mumi/messages.scm
@@ -331,6 +331,48 @@ of message parts."
                                  matches)) amount)))
     (soap-invoke* (%config 'debbugs) get-status 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-public (process-query query)
   "Process the QUERY string and return two values: the remaining
 unprocessed query string and an alist of search attributes."
@@ -352,6 +394,33 @@ unprocessed query string and an alist of search attributes."
                   #: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))))
                (("title" title)
                 `(#:terms ,terms
                   #:attributes ,(cons `(subject string-contains ,title) attrs)