blob: 708f0895b5234f39e4afd151f22aba9159673233 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
(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 (srfi srfi-111)
)
;; 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)
(case char
((#\() (1+ count))
((#\)) (1- count))
(else count)))
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?
(eval `(lambda (event) ,@expressions)
(make-sandbox-module
`(
((vcomponent base) prop)
((ice-9 regex) string-match)
;; TODO datetime
,@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 (unbox (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)))
(let ((list (reverse lst)))
(set-box! (stream-ref query page)
(list->stream list))
list)))
;; 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-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)
(set-max-page! paginator (get-max-page paginator))
(set-true-max-page! paginator #t)
(throw 'max-page (get-max-page paginator)))))
|
