Merge branch 'smalltime' into master

4 files changed, 96 insertions, 31 deletions

diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm
index f0ebc3e0..5b819176 100644
--- a/module/entry-points/server.scm
+++ b/module/entry-points/server.scm
@@ -62,6 +62,10 @@
             (cdr (scandir dir))))))
 
 (define get-query-page
+  ;; A user of the website is able to fill up all of the hosts memory by
+  ;; requesting a bunch of different search pages, and forcing a bunch
+  ;; of pages on each. Clean up this table from time to time, possibly
+  ;; by popularity-rank.
   (let ((query-pages (make-hash-table)))
    (lambda (search-term)
      (aif (hash-ref query-pages search-term)
@@ -287,6 +291,7 @@
              (return (build-response code: 404)
                      (format #f "No component with UID=~a found." uid))))
 
+   ;; TODO search without query should work
    (GET "/search" (q p)
         (define search-term (prepare-string q))
 
@@ -302,6 +307,11 @@
         ;; TODO Propagate errors
         (define search-result
           (catch 'max-page
+            ;; TODO Get-page only puts a time limiter per page, meaning that
+            ;; if a user requests page 1000 the server is stuck trying to
+            ;; find that page, which can take up to 1000 * timeslice = 500s = 8min+
+            ;; A timeout here, and also an actual multithreaded server should
+            ;; solve this.
             (lambda () (get-page paginator page))
             (lambda (err page-number)
               (define location
diff --git a/module/output/terminal.scm b/module/output/terminal.scm
index 8fcb9cd5..7042ead8 100644
--- a/module/output/terminal.scm
+++ b/module/output/terminal.scm
@@ -294,6 +294,7 @@
   )
 
 (define-method (input (this <search-view>) char)
+  ;; TODO update this to match actual page length
   (set! (page-length this) 10)
 
   (case char
diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm
index 472170d7..51671985 100644
--- a/module/srfi/srfi-41/util.scm
+++ b/module/srfi/srfi-41/util.scm
@@ -1,8 +1,10 @@
 (define-module (srfi srfi-41 util)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-41)
+  #:use-module ((ice-9 sandbox) :select (call-with-time-limit))
   #:use-module (util) ; let*, find-min
-  #:export (stream-car+cdr interleave-streams with-streams))
+  #:export (stream-car+cdr interleave-streams with-streams
+                           stream-timeslice-limit))
 
 (define (stream-car+cdr stream)
   (values (stream-car stream)
@@ -102,6 +104,22 @@
 (define*-public (stream-paginate stream optional: (page-size 10))
   (stream-paginate% stream page-size))
 
+
+;; stream cons, but eval arguments beforehand.
+(define (eager-stream-cons a b)
+  (stream-cons a b))
+
+;; Wrap a stream in time limits. Each element has at most @var{timeslice}
+;; seconds to produce a value, otherwise the stream ends. Useful for finding the
+;; "final" element matching a predicate in an infinite stream.
+(define-stream (stream-timeslice-limit strm timeslice)
+  (call-with-time-limit
+   timeslice
+   (lambda () (eager-stream-cons
+          (stream-car strm)
+          (stream-timeslice-limit (stream-cdr strm) timeslice)))
+   (lambda _ stream-null)))
+
 ;; Evaluates @var{body} in a context where most list fundamentals are
 ;; replaced by stream alternatives.
 ;; commented defifinitions are items which could be included, but for
diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm
index 65e2630a..fab53f79 100644
--- a/module/vcomponent/search.scm
+++ b/module/vcomponent/search.scm
@@ -1,11 +1,38 @@
+;;; Commentary:
+
+;; Procedures for searching in a (possibly) infinite stream. Everything is general,
+;; with the exception of @var{build-query-proc}, which is tailored for searches on
+;; sets on vcomponents.
+
+;; > TODO since most of this module is generic, break it out and only have the
+;; > vcomponent-specific parts here.
+
+;; A search isn't guaranteed to include all available objects, since each object
+;; only has a limited time to get found. This is mostly a problem if the matches
+;; are /really/ far from one another.
+;; NOTE a system of continuations to allow a search to be resumed with a higher
+;; timeout would be cool to have.
+
+;; Currently all searches is assumed to go through prepare-query and the paginator
+;; interface. It shouldn't however be a problem to work with the flat result-set
+;; returned by @var{execute-query} directly.
+
+;; @var{<paginator>} isn't strictly necessary even for paginated queries, since the
+;; evaluation time and pagination is baked into the stream. It is however useful
+;; for keeping track of the number of available pages, and if we have found the
+;; "final" element.
+
+;;; Code:
+
 (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)
-  )
+  :use-module ((ice-9 sandbox)
+               :select (make-sandbox-module
+                        all-pure-bindings)))
 
 
 ;; Takes a string and appends closing parenthese until all parenthese are
@@ -42,35 +69,35 @@
            ,@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))
-  (let ((lst '()))
-    (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 ()
-       (let loop ((strm (stream-ref query page)))
-         (if (stream-null? strm) lst
-             (set! lst (cons (stream-car strm) lst))
-             (loop (stream-cdr strm)))))
-     (lambda _ (format (current-error-port) "~a~%" 'timed-out)))
-    (reverse lst)))
 
+;; Returns a new stream which is the result of filtering the input set with the
+;; query procedure.
+;; (a → bool), (stream a) → (stream a)
+(define (execute-query query-proc event-set)
+  (stream-timeslice-limit
+   (stream-filter query-proc event-set)
+   ;; .5s, tested on my laptop. .1s sometimes doesn't get to events on
+   ;; 2020-08-10, where the first event is on 1974-12-02.
+   0.5))
 
 ;; Creates a prepared query wrappend in a paginator.
 ;; (event → bool), (stream event) → <paginator>
-(define-public (prepare-query query-proc event-set)
-  (make-paginator (stream-paginate (stream-filter query-proc event-set))))
+(define*-public (prepare-query query-proc event-set optional: (page-size 10))
+  (make-paginator (stream-paginate (execute-query query-proc event-set)
+                                   page-size)))
 
 (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!))
+  (true-max-page? true-max-page? %set-true-max-page!))
+
+(define (set-true-max-page! paginator)
+  (%set-true-max-page! paginator #t))
+
+(define (unset-true-max-page! paginator)
+  (%set-true-max-page! paginator #f))
 
 (export paginator? get-query get-max-page true-max-page?)
 
@@ -110,15 +137,24 @@
 ;; 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)
+  (catch 'wrong-type-arg
+    (lambda () (let ((q (get-query paginator)))
+            (if (stream-null? q)
+                (begin
+                  (set-true-max-page! paginator)
+                  '())
+                (let ((result (stream->list
+                               (stream-ref (get-query paginator) page))))
+                  (when (> 10 (length result))
+                    (set-true-max-page! paginator))
+
+                  (set-max-page! paginator (max page (get-max-page paginator)))
+                  result))))
+    (lambda (err proc fmt args data)
+      ;; (format (current-error-port) "~?~%" fmt args)
       (set-max-page! paginator (get-max-page paginator))
-      (set-true-max-page! paginator #t)
-      (throw 'max-page (get-max-page paginator)))))
+      (set-true-max-page! paginator)
+      (throw 'max-page (get-max-page paginator))
+      )))