Add paginator, use in in html and term.

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 <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 '()) |# '())
-         ))))
-  )
+(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-view> (<view>)
   (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-view> 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 <search-view>))
-  (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 <view>) 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) → <paginator>
 (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 <paginator>
+  (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
+;; <paginator>, 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.
+;; <paginator>, int → (list event) throws ('max-page <int>)
+(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