1 files changed, 63 insertions, 0 deletions
diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm
new file mode 100644
index 00000000..e92e166f
--- /dev/null
+++ b/module/vcomponent/search.scm
@@ -0,0 +1,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 #t
+    (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
+      '())))