diff options
-rw-r--r-- | module/entry-points/server.scm | 10 | ||||
-rw-r--r-- | module/output/terminal.scm | 1 | ||||
-rw-r--r-- | module/srfi/srfi-41/util.scm | 20 | ||||
-rw-r--r-- | module/vcomponent/search.scm | 96 |
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)) + ))) |