From e2a602d16dfad5325960dec0a16ee2b88560a36f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 9 Aug 2020 15:44:44 +0200 Subject: Add basic (semi broken) paginator to HTML search. --- module/entry-points/server.scm | 91 ++++++++++++++++++++++++++++++++---------- module/output/html-search.scm | 39 ++++++++++++++++++ module/output/html.scm | 16 ++++---- module/server/macro.scm | 37 +++++++++-------- module/vcomponent/search.scm | 4 +- static/style.css | 8 ++++ 6 files changed, 145 insertions(+), 50 deletions(-) create mode 100644 module/output/html-search.scm 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 + (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 ---------------------------------------- */ -- cgit v1.2.3