From ab5df6ea74d6275a555b8a615131df876159b4f1 Mon Sep 17 00:00:00 2001
From: Ricardo Wurmus <rekado@elephly.net>
Date: Wed, 22 Apr 2020 15:01:41 +0200
Subject: xapian: Add sanitize-date-range.

---
 mumi/xapian.scm | 46 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 46 insertions(+)

diff --git a/mumi/xapian.scm b/mumi/xapian.scm
index f1ad7a4..b00e8ee 100644
--- a/mumi/xapian.scm
+++ b/mumi/xapian.scm
@@ -135,6 +135,52 @@ messages and index their contents in the Xapian database at DBPATH."
         (unless (null? rest)
           (loop rest))))))
 
+(define (sanitize-date-range token)
+  (define now (current-time))
+  (define (days n)
+    (make-time time-duration 0 (* 60 60 24 n)))
+  (define (range-boundary->date-string boundary*)
+    (define boundary (string-delete #\- boundary*))
+    (cond
+     ((string->number boundary) boundary)
+     (else
+      (let ((date (match boundary
+                    ((or "now" "today") now)
+                    ("yesterday" (subtract-duration now (days 1)))
+                    (_
+                     (call-with-values
+                         (lambda () (span char-numeric? (string->list boundary)))
+                       (lambda (pre post)
+                         (let ((n (string->number (apply string pre)))
+                               (unit (apply string post)))
+                           (and n
+                                (subtract-duration
+                                 now
+                                 (match unit
+                                   ((or "d" "day" "days")
+                                    (days n))
+                                   ((or "w" "week" "weeks")
+                                    (days (* n 7)))
+                                   ((or "m" "month" "months")
+                                    (days (* n 30)))
+                                   ((or "y" "year" "years")
+                                    (days (* n 365)))))))))))))
+        (and date
+             (date->string (time-utc->date date) "~Y~m~d"))))))
+  (if (or (string-prefix? "date:" token)
+          (string-prefix? "mdate:" token))
+      (match (string-split token (char-set #\: #\.))
+        ((prefix begin sep end)
+         (let ((begin* (range-boundary->date-string begin))
+               (end*   (if (or (not end) (string-null? end)) ""
+                           (or (range-boundary->date-string end) ""))))
+           (if begin*
+               (string-append prefix ":" begin* ".." end*)
+               (string-append begin " " end))))
+        ;; Swallow invalid tokens silently to avoid crashing Xapian
+        (invalid (pk invalid "")))
+      token))
+
 (define* (parse-query* querystring #:key stemmer stemming-strategy (prefixes '()))
   (let ((queryparser (new-QueryParser))
         (date-range-processor (new-DateRangeProcessor 0 "date:" 0))
-- 
cgit v1.2.3