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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
;;; 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 util search)
:use-module (hnh util)
: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))
:export (prepare-string
build-query-proc
execute-query
prepare-query
paginator?
get-query get-max-page true-max-page?
next-page
paginator->list
paginator->sub-list
get-page))
;; 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 (prepare-string str)
(call-with-input-string (close-parenthese str) read))
;; TODO place this in a proper module
(define (bindings-for module-name)
;; Wrapping list so we can later export sub-modules.
(list (cons module-name
(module-map (lambda (a . _) a)
(resolve-interface module-name)))))
;; 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 (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 param children type parent)
((ice-9 regex) string-match)
,@(bindings-for '(datetime))
,@all-pure-bindings)
)))
;; 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* (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!))
(define (set-true-max-page! paginator)
(%set-true-max-page! paginator #t))
(define (unset-true-max-page! paginator)
(%set-true-max-page! paginator #f))
(define (make-paginator query)
(make-paginator% query 0 #f))
;; a fancy version of 1+ which caps at max page
;; <paginator>, int → int
(define* (next-page paginator optional: (page (get-max-page paginator)))
(if (true-max-page? paginator)
(min (1+ page) (get-max-page paginator))
(1+ page)))
(define (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* (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 (get-page paginator page)
(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))))
;; This check isn't strictly necessary, but without it
;; we always needs to force the next page. And since this
;; page is "incomplete" we already know that this is the
;; final 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)
;; NOTE This is mostly a hack to see that we
;; actually check for the correct error.
(unless (string=? fmt "beyond end of stream")
(scm-error err proc fmt args data))
(set-max-page! paginator (get-max-page paginator))
(set-true-max-page! paginator)
(throw 'max-page (get-max-page paginator))
)))
|
