blob: 5cb91e5136622f6a99421a3e4aa5ccf27d67d89c (
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
|
(define-module (vcomponent search)
:use-module (util)
:use-module (ice-9 sandbox)
:use-module (srfi srfi-41)
:use-module (srfi srfi-41 util)
)
(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 #\))))
(define-public (prepare-string str)
(call-with-input-string (close-parenthese str) read))
(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)
)))
(define-public (prepare-query query-proc event-set)
(stream-paginate (stream-filter query-proc event-set)) )
;; TODO possibly make this procedure deny any query-procedures not created by
;; build-query-procedure
;; (event → bool), (stream event), (() → Any) → (paginated-stream event)
(define*-public (execute-query query page
key:
;; time-out-handler
(time-limit 1))
(catch 'not-an-actual-error ; 'timed-out
(lambda ()
(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 () (stream->list (stream-ref query page)))
(lambda _ (throw 'timed-out))))
(lambda (err . args)
(display (cons err args) (current-error-port))
(newline (current-error-port))
(case err
((timed-out) (aif time-out-handler (it)
(apply throw err 'args))))
'timed-out ; when search took to long
'unbound-variable ; when search term has unbound variables
'wrong-type-arg ;; stream-ref
'())))
|
