From 929640aa3fbb496c404b584d95c4d8001f667a19 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 9 Aug 2020 22:15:34 +0200 Subject: Add paginator, use in in html and term. --- module/entry-points/server.scm | 77 +++++++++-------------------- module/output/html-search.scm | 21 ++++---- module/output/terminal.scm | 97 ++++++++++++++++++------------------ module/server/macro.scm | 5 +- module/vcomponent/search.scm | 109 +++++++++++++++++++++++++++++++---------- static/style.css | 5 +- 6 files changed, 170 insertions(+), 144 deletions(-) diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 866c7781..f0ebc3e0 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -61,39 +61,18 @@ (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 '()) |# '()) - )))) - ) +(define get-query-page + (let ((query-pages (make-hash-table))) + (lambda (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)))) + (hash-set! query-pages search-term q) + q))))) + + ;; TODO ensure encoding on all fields which take user provided data. @@ -270,7 +249,7 @@ (return (build-response code: 302 - headers: `((location . ,location))) + headers: `((location ,location))) "")) (GET "/calendar" (start end) @@ -309,9 +288,6 @@ (format #f "No component with UID=~a found." uid)))) (GET "/search" (q p) - - - (define search-term (prepare-string q)) (define q= (find (lambda (s) @@ -319,38 +295,29 @@ (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)))))))) + (define paginator (get-query-page search-term)) - (begin - (set! (cdr (get-max-page query)) - (max (1+ page) (cdr (get-max-page query)))) - (1+ page))))) + (define page (string->number (or p "0"))) ;; TODO Propagate errors (define search-result (catch 'max-page - (lambda () (run-query query page)) + (lambda () (get-page paginator page)) (lambda (err page-number) + (define location + (build-relative-ref + path: r:path ; host: r:host port: r:port + query: (format #f "~a&p=~a" q= page-number))) (return (build-response code: 307 - headers: `((location - . ,(format #f "?~a&p=~a" q page-number)))))))) + headers: `((location . ,location))))))) (return '((content-type application/xhtml+xml)) (with-output-to-string (lambda () (sxml->xml ((@ (output html-search) search-result-page) - search-term search-result (get-max-page query) q=)))))) + search-term search-result page paginator 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 index e8414d18..a6a80cd4 100644 --- a/module/output/html-search.scm +++ b/module/output/html-search.scm @@ -2,10 +2,11 @@ (define-module (output html-search) :use-module (util) :use-module (vcomponent) + :use-module (vcomponent search) :use-module (ice-9 format) ) -(define-public (search-result-page search-term search-result mp q=) +(define-public (search-result-page search-term search-result page paginator q=) `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") (html (@ (xmlns "http://www.w3.org/1999/xhtml") (lang sv)) @@ -21,19 +22,17 @@ (style "width:100%")) ,(format #f "~y" search-term))) (input (@ (type submit)))) - (h2 "Result") + (h2 "Result (page " ,page ")") (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))) - "»")))) - )) + ,@(paginator->list + paginator + (lambda (p) (if (= p page) + `(span ,p) + `(a (@ (href "?" ,q= "&p=" ,p)) ,p))) + (lambda (p) `(a (@ (href "?" ,q= "&p=" ,p)) "»")))) )))) + diff --git a/module/output/terminal.scm b/module/output/terminal.scm index e6476de7..4d12b48d 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -177,6 +177,22 @@ (set! (current-page this) (current-date) (active-element this) 0)) + ((#\/) (set-cursor-pos 0 (1- height)) + (let* ((attr (make-termios)) + (search-term #f)) + (tcgetattr! attr) + (set! (lflag attr) (logior ECHO (lflag attr))) + (tcsetattr! attr) + (system "tput cnorm") + (set! search-term (readline "quick search: ")) + (system "tput civis") + (set! (lflag attr) (logand (lognot ECHO) (lflag attr))) + (tcsetattr! attr) + `(push ,(search-view + (format #f "(regexp-exec (make-regexp \"~a\" regexp/icase) (prop event 'SUMMARY))" + search-term) + (get-event-set this))))) + ((#\() (set-cursor-pos 0 (1- height)) (let* ((attr (make-termios)) (search-term #f)) @@ -198,12 +214,7 @@ (define-class () (search-result getter: search-result) (search-term accessor: search-term - init-keyword: search-term:) - (max-page accessor: max-page - init-form: (cons #f 0)) - (cached-page accessor: cached-page - init-value: #f ) - ) + init-keyword: search-term:)) (define (search-view search-term event-set) (make search-term: search-term event-set: event-set)) @@ -219,21 +230,21 @@ (let ((q (build-query-proc (search-term this)))) (slot-set! this 'search-result (prepare-query - q - (get-event-set this)))) + q (get-event-set this)))) ;; (define current-page 0) ;; (define current-entry 0) ) (define-method (output (this )) - (unless (cached-page this) - (set! (cached-page this) - (execute-query - (slot-ref this 'search-result) - (current-page this) - time-out-handler: - (lambda () (set! (max-page this) (cons #t (1- (current-page this))) - (current-page this) (cdr (max-page this))))))) + + (define paginator (slot-ref this 'search-result)) + + (define page + (catch 'max-page + (lambda () (get-page paginator (current-page this))) + (lambda (err page-number) + (set! (current-page this) page-number) + (get-page paginator page-number)))) (cls) @@ -245,31 +256,27 @@ ;; display event list (display-event-table - (cached-page this) + page #:active-element (active-element this) #:location-width 15) - ;; display page counter - (let ((start (max 0 (- (current-page this) 5))) - (end (min (+ (current-page this) 5) (cdr (max-page this))))) - - (display + (paginator->sub-list + paginator (current-page this) + (lambda (i) + (if (= i (current-page this)) + (format #t "[~2@a]" i) + (format #t " ~2@a " i))) + head-proc: + (lambda (start) (if (= start 0) "|" "<")) - - (for-each (lambda (i) - (if (= i (current-page this)) - (format #t "[~2@a]" i) - (format #t " ~2@a " i))) - (iota (1+ (- end start)) start)) - - - (display - (if (= end (cdr (max-page this))) - (if (car (max-page this)) + tail-proc: + (lambda (end) + (if (= end (get-max-page paginator)) + (if (true-max-page? paginator) "|" "?") - ">")) - (newline))) + ">"))) + (newline)) (define-method (input (this ) char) (case char @@ -290,20 +297,16 @@ (case char ((#\newline) `(push ,(day-view (get-event-set this) - (as-date (prop (list-ref (cached-page this) + (as-date (prop (list-ref (get-page (slot-ref this 'search-result) + (current-page this)) (active-element this)) 'DTSTART))))) - ((#\h) (set! (current-page this) = ((lambda (old) (max 0 (1- old)))) - (cached-page this) #f)) - ((#\l) (set! (current-page this) = ((lambda (old) - ;; true final page - (if (car (max-page this)) - (min (1+ old) (cdr (max-page this))) - (begin - (set! (cdr (max-page this)) - (max (1+ old) (cdr (max-page this)))) - (1+ old))))) - (cached-page this) #f)) + ((#\h) (set! (current-page this) = ((lambda (old) (max 0 (1- old)))))) + ((#\l) + (display "\n loading...\n") + (set! (current-page this) + (next-page (slot-ref this 'search-result) + (current-page this)))) (else (next-method)))) (define-public (main-loop date) diff --git a/module/server/macro.scm b/module/server/macro.scm index 3fdfd06b..b6983c7e 100644 --- a/module/server/macro.scm +++ b/module/server/macro.scm @@ -60,6 +60,7 @@ (define-macro (make-routes . routes) `(lambda* (request body #:optional state) + (format (current-error-port) "~a~%" request) ;; ALl these bindings generate compile time warnings since the expansion ;; of the macro might not use them. This isn't really a problem. (let ((r:method (request-method request)) @@ -70,8 +71,8 @@ (r:port (request-port request))) (let ((r:scheme (uri-scheme r:uri)) (r:userinfo (uri-userinfo r:uri)) - (r:host (uri-host r:uri)) - (r:port (uri-port r:uri)) + (r:host (or (uri-host r:uri) (request-host request))) + (r:port (or (uri-port r:uri) (request-port request))) (r:path (uri-path r:uri)) (r:query (uri-query r:uri)) (r:fragment (uri-fragment r:uri))) diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm index 5cb91e51..571279e7 100644 --- a/module/vcomponent/search.scm +++ b/module/vcomponent/search.scm @@ -1,11 +1,15 @@ (define-module (vcomponent search) :use-module (util) :use-module (ice-9 sandbox) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) ) +;; Takes a string and appends closing parenthese until all parenthese are +;; closed. (define (close-parenthese str) (define missing-parenthesis-count (string-fold (lambda (char count) @@ -16,9 +20,16 @@ 0 str)) (string-append str (make-string missing-parenthesis-count #\)))) +;; Prepares a string to be sent to build-query-proc +;; sexp-like string -> sexp (define-public (prepare-string str) (call-with-input-string (close-parenthese str) read)) +;; Evaluates the given expression in a sandbox. +;; NOTE Should maybe be merged inte prepare-query. The argument against is that +;; eval-in-sandbox is possibly slow, and that would prevent easy caching by the +;; caller. +;; sexp -> (event → bool) (define-public (build-query-proc . expressions) ;; TODO does this eval help? Or will the body of the procedure ;; be evalutade later? @@ -31,33 +42,77 @@ ,@all-pure-bindings) ))) +;; execute a query procedure created by build-query-proc. +;; (event → bool), int, (optional int) → (list event) throws 'timed-out +(define* (execute-query query page key: (time-limit 1)) + (call-with-time-limit + time-limit + ;; Stream->list needs to be here, since the actual + ;; stream-force needs to happen within the actual + ;; @var{call-with-time-limit}. + (lambda () (stream->list (stream-ref query page))) + (lambda _ (throw 'timed-out)))) + +;; Creates a prepared query wrappend in a paginator. +;; (event → bool), (stream event) → (define-public (prepare-query query-proc event-set) - (stream-paginate (stream-filter query-proc event-set)) ) - -;; TODO possibly make this procedure deny any query-procedures not created by -;; build-query-procedure -;; (event → bool), (stream event), (() → Any) → (paginated-stream event) -(define*-public (execute-query query page - key: - ;; time-out-handler - (time-limit 1)) - (catch 'not-an-actual-error ; 'timed-out - (lambda () - (call-with-time-limit - time-limit - ;; Stream->list needs to be here, since the actual - ;; stream-force needs to happen within the actual - ;; @var{call-with-time-limit}. - (lambda () (stream->list (stream-ref query page))) - (lambda _ (throw 'timed-out)))) + (make-paginator (stream-paginate (stream-filter query-proc event-set)))) + +(define-record-type + (make-paginator% query max-page true-max-page?) + paginator? + (query get-query) ; (paginated-stream event) + (max-page get-max-page set-max-page!) ; int + (true-max-page? true-max-page? set-true-max-page!)) + +(export paginator? get-query get-max-page true-max-page?) + +(define (make-paginator query) + (make-paginator% query 0 #f)) + +;; a fancy version of 1+ which caps at max page +;; , int → int +(define*-public (next-page paginator optional: (page (get-max-page paginator))) + (if (true-max-page? paginator) + (min (1+ page) (get-max-page paginator)) + (1+ page))) + +(define-public (paginator->list paginator proc tail-proc) + (if (true-max-page? paginator) + (map proc (iota (1+ (get-max-page paginator)))) + (append (map proc (iota (1+ (get-max-page paginator)))) + (list (tail-proc (next-page paginator)))))) + + +(define*-public (paginator->sub-list paginator current-page proc + key: head-proc tail-proc + (ahead 5) (behind 5) + ) + + (let ((start (max 0 (- current-page behind))) + (end (min (+ current-page ahead) + (get-max-page paginator)))) + + (display (head-proc start)) + (for-each proc (iota (1+ (- end start)) start)) + (display (tail-proc end))) + + ) + +;; returns the contents of the requested page, or throws 'max-page with the +;; highest known available page. +;; , int → (list event) throws ('max-page ) +(define-public (get-page paginator page) + (catch 'timed-out + (lambda () (let ((result (execute-query (get-query paginator) page))) + (set-max-page! paginator (max page (get-max-page paginator))) + (when (> 10 (length result)) + (set-true-max-page! paginator #t)) + result)) (lambda (err . args) - (display (cons err args) (current-error-port)) - (newline (current-error-port)) - (case err - ((timed-out) (aif time-out-handler (it) - (apply throw err 'args)))) - 'timed-out ; when search took to long - 'unbound-variable ; when search term has unbound variables - 'wrong-type-arg ;; stream-ref - '()))) + (set-max-page! paginator (get-max-page paginator)) + (set-true-max-page! paginator #t) + (throw 'max-page (get-max-page paginator))))) + + diff --git a/static/style.css b/static/style.css index e2b6a8d1..563a8fa1 100644 --- a/static/style.css +++ b/static/style.css @@ -666,8 +666,9 @@ along with their colors. ---------------------------------------- */ -.paginator a { - padding: 1em; +.paginator > * { + padding-left: 1em; + display: inline-block; } /* Popups -- cgit v1.2.3