blob: 6e7292c264c0c36dc04e8f3b2b17f077b740beea (
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
129
130
|
(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)))
(if (null? list)
list
(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)))))
|
