Add basic (semi broken) paginator to HTML search.

6 files changed, 145 insertions, 50 deletions

diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm
index 7a753b8b..866c7781 100644
--- a/module/entry-points/server.scm
+++ b/module/entry-points/server.scm
@@ -5,6 +5,7 @@
   :use-module (util exceptions)
 
   :use-module (srfi srfi-1)
+  :use-module (srfi srfi-17)
 
   :use-module (ice-9 match)
   :use-module (ice-9 control)
@@ -60,6 +61,40 @@
                      (td ,(number->string (stat:perms stat) 8)))))
             (cdr (scandir dir))))))
 
+(use-modules (srfi srfi-9))
+
+(define-record-type <query-page>
+  (make-query-page search-term query max-page errors)
+  query-page?
+  (search-term get-search-term)
+  (query get-query)
+  (max-page get-max-page set-max-page!)
+  (errors get-errors%))
+
+(define query-pages (make-hash-table))
+
+(define (get-query-page search-term)
+  (aif (hash-ref query-pages search-term)
+       it
+       (let* ((q (prepare-query
+                 (build-query-proc search-term)
+                 (get-event-set global-event-object)))
+              (qp (make-query-page search-term q (cons #f 0) '())))
+         (hash-set! query-pages search-term qp)
+         qp)))
+
+(define (run-query query-page page)
+  (catch 'timed-out
+    (lambda () (execute-query (get-query query-page) page))
+    (lambda (err . args)
+      (case err
+        ((timed-out)
+         (set-max-page! query-page (cons #t (1- page)))
+         (throw 'max-page (1- page))
+         ; (values (1- page) #| events here? (instead of '()) |# '())
+         ))))
+  )
+
 
 ;; TODO ensure encoding on all fields which take user provided data.
 ;; Possibly a fallback which strips everything unknown, and treats
@@ -273,35 +308,49 @@
              (return (build-response code: 404)
                      (format #f "No component with UID=~a found." uid))))
 
-   (GET "/search" (q)
+   (GET "/search" (q p)
+
+
+
         (define search-term (prepare-string q))
-        (define query-proc (build-query-proc search-term))
-        (define query (prepare-query
-                       query-proc
-                       (get-event-set global-event-object)))
 
+        (define q= (find (lambda (s)
+                           (and (<= 2 (string-length s))
+                                (string=? "q=" (string-take s 2))))
+                         (string-split r:query #\&)))
+
+        (define query (get-query-page search-term))
+
+        (define page
+          (let ((page (string->number (or p "0"))))
+            (if (car (get-max-page query)) ; true final page
+                (return (build-response
+                         code: 307
+                         headers: `((location
+                                     . ,(format #f "?~a&p=~a" q
+                                                (min (1+ page) (cdr (get-max-page query))))))))
+
+                (begin
+                  (set! (cdr (get-max-page query))
+                    (max (1+ page) (cdr (get-max-page query))))
+                  (1+ page)))))
+
+        ;; TODO Propagate errors
         (define search-result
-          (execute-query query 0))
+          (catch 'max-page
+            (lambda () (run-query query page))
+            (lambda (err page-number)
+              (return (build-response
+                       code: 307
+                       headers: `((location
+                                   . ,(format #f "?~a&p=~a" q page-number))))))))
 
         (return '((content-type application/xhtml+xml))
                 (with-output-to-string
                   (lambda ()
                     (sxml->xml
-                     `(*TOP*
-                       (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
-                       (html (@ (xmlns "http://www.w3.org/1999/xhtml") (lang sv))
-                        (head (title "Search results"))
-                        (body
-                         (h2 "Search term")
-                         (form
-                          (pre (textarea (@ (name "q") (rows 5) (spellcheck false)
-                                            (style "width:100%"))
-                                         ,(format #f "~y" search-term)))
-                          (input (@ (type submit))))
-                         (h2 "Result")
-                         ,@(for event in search-result
-                                `(div (@ (class "event"))
-                                      ,(prop event 'SUMMARY)))))))))))
+                     ((@ (output html-search) search-result-page)
+                      search-term search-result (get-max-page query) q=))))))
 
    ;; NOTE this only handles files with extensions. Limited, but since this
    ;; is mostly for development, and something like nginx should be used in
diff --git a/module/output/html-search.scm b/module/output/html-search.scm
new file mode 100644
index 00000000..e8414d18
--- /dev/null
+++ b/module/output/html-search.scm
@@ -0,0 +1,39 @@
+;; TODO rename this module
+(define-module (output html-search)
+  :use-module (util)
+  :use-module (vcomponent)
+  :use-module (ice-9 format)
+  )
+
+(define-public (search-result-page search-term search-result mp q=)
+  `(*TOP*
+    (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+    (html (@ (xmlns "http://www.w3.org/1999/xhtml") (lang sv))
+          (head (title "Search results")
+                ;; TODO (@ (output html) include-css)
+                (link (@ (type "text/css")
+                         (rel "stylesheet")
+                         (href "/static/style.css"))))
+          (body
+           (h2 "Search term")
+           (form
+            (pre (textarea (@ (name "q") (rows 5) (spellcheck false)
+                              (style "width:100%"))
+                           ,(format #f "~y" search-term)))
+            (input (@ (type submit))))
+           (h2 "Result")
+           (ul
+            ,@(for event in search-result
+                   `(li (@ (class "event"))
+                        ,(prop event 'SUMMARY))))
+           (div (@ (class "paginator"))
+                ,@(let ()
+                    (define (make-link n) `(a (@ (href "?" ,q= "&p=" ,n))
+                                              ,n))
+                    (if (car mp)         ; true max page
+                        (map make-link (iota (cdr mp)))
+                        (append (map make-link (iota (cdr mp)))
+                                `((a (@ (href "?" ,q= "&p=" ,(cdr mp)))
+                                     "»"))))
+                    ))
+           ))))
diff --git a/module/output/html.scm b/module/output/html.scm
index e3668f08..6e6fcd30 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -125,6 +125,7 @@
                `(div (@ (class "tab"))
                      (input (@ (type "radio") (id ,id) (name ,tabgroup)
                                ,@(when (zero? i) '((checked)))))
+                     ;; TODO title attribute for label
                      (label (@ (for ,id) (style "top: " ,(* 6 i) "ex")) ,key)
                      (div (@ (class "content")) ,body)))))
 
@@ -144,14 +145,13 @@
                         onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))"))
 
              ,(tabset
-               (append
-                `(("📅" ,(fmt-single-event ev))
-                  ("⤓" (div (@ (style "font-family:sans"))
-                            (p "Ladda ner")
-                            (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics"))
-                                       "som iCal"))
-                                (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs"))
-                                       "som xCal")))))))))))
+               `(("📅" ,(fmt-single-event ev))
+                 ("⤓" (div (@ (style "font-family:sans"))
+                           (p "Ladda ner")
+                           (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics"))
+                                      "som iCal"))
+                               (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs"))
+                                      "som xCal"))))))))))
 
 
 
diff --git a/module/server/macro.scm b/module/server/macro.scm
index 99272a75..3fdfd06b 100644
--- a/module/server/macro.scm
+++ b/module/server/macro.scm
@@ -75,25 +75,24 @@
              (r:path     (uri-path     r:uri))
              (r:query    (uri-query    r:uri))
              (r:fragment (uri-fragment r:uri)))
-
-
          (call-with-values
              (lambda ()
-              (call/ec (lambda (return)
-                         (apply
-                          (cond ,@(map generate-case routes)
-                                (else (lambda* _ (return (build-response #:code 404)
-                                                         "404 Not Fonud"))))
-                          (append
-                           (parse-query r:query)
+               (call/ec (lambda (return)
+                          (apply
+                           (cond ,@(map generate-case routes)
+                                 (else (lambda* _ (return (build-response #:code 404)
+                                                          "404 Not Fonud"))))
+                           (append
+                            (parse-query r:query)
 
-                           (let ((content-type (assoc-ref r:headers 'content-type)))
-                             (when content-type
-                               (let ((type (car content-type))
-                                     (args (cdr content-type)))
-                                 (when (eq? type 'application/x-www-form-urlencoded)
-                                   (let ((encoding (or (assoc-ref args 'encoding) "UTF-8")))
-                                     (parse-query (bytevector->string body encoding)
-                                                  encoding)))))))))))
-           (lambda* (a b #:optional new-state)
-             (values a b (or new-state state))))))))
+                            (let ((content-type (assoc-ref r:headers 'content-type)))
+                              (when content-type
+                                (let ((type (car content-type))
+                                      (args (cdr content-type)))
+                                  (when (eq? type 'application/x-www-form-urlencoded)
+                                    (let ((encoding (or (assoc-ref args 'encoding) "UTF-8")))
+                                      (parse-query (bytevector->string body encoding)
+                                                   encoding)))))))))))
+           (case-lambda ((headers body new-state) (values headers body new-state))
+                        ((headers body) (values headers body state))
+                        ((headers) (values headers "" state))))))))
diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm
index e92e166f..5cb91e51 100644
--- a/module/vcomponent/search.scm
+++ b/module/vcomponent/search.scm
@@ -40,9 +40,9 @@
 ;; (event → bool), (stream event), (() → Any) → (paginated-stream event)
 (define*-public (execute-query query page
                                key:
-                               time-out-handler
+                               ;; time-out-handler
                                (time-limit 1))
-  (catch #t
+  (catch 'not-an-actual-error ; 'timed-out
     (lambda ()
       (call-with-time-limit
        time-limit
diff --git a/static/style.css b/static/style.css
index 23561a73..e2b6a8d1 100644
--- a/static/style.css
+++ b/static/style.css
@@ -662,6 +662,14 @@ along with their colors.
 .clock-24 { top: calc(100%/24 * 24); }
 
 
+/* Search page
+----------------------------------------
+ */
+
+.paginator a {
+    padding: 1em;
+}
+
 /* Popups
 ----------------------------------------
 */