source: project/release/4/qwiki/trunk/qwiki-search.scm @ 32670

Last change on this file since 32670 was 32670, checked in by sjamaan, 5 years ago

qwiki: Make qwiki-search module use irregex directly (the loading of "regex" and importing of "irregex" isn't necessary since 4.7.0 or so)

File size: 10.6 KB
Line 
1;;
2;; qwiki-search - search extension for qwiki
3;;
4;; Copyright (c) 2009-2012 Peter Bex
5;;
6;;  Redistribution and use in source and binary forms, with or without
7;;  modification, are permitted provided that the following conditions
8;;  are met:
9;;
10;;  - Redistributions of source code must retain the above copyright
11;;  notice, this list of conditions and the following disclaimer.
12;;
13;;  - Redistributions in binary form must reproduce the above
14;;  copyright notice, this list of conditions and the following
15;;  disclaimer in the documentation and/or other materials provided
16;;  with the distribution.
17;;
18;;  - Neither name of the copyright holders nor the names of its
19;;  contributors may be used to endorse or promote products derived
20;;  from this software without specific prior written permission.
21;;
22;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
23;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
24;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
25;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
26;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
27;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
29;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
30;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
31;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34;;  POSSIBILITY OF SUCH DAMAGE.
35
36(module qwiki-search
37        (create-search-node! search-install! search-server-uri
38         wiki-page->estraier-doc)
39
40(import chicken scheme)
41(use data-structures extras srfi-1 srfi-13 intarweb uri-common spiffy
42     qwiki qwiki-sxml sxml-transforms sxpath sxpath-lolevel estraier-client irregex)
43
44(define search-server-uri
45  (make-parameter (or (get-environment-variable "QWIKI_SEARCH_URI")
46                      "http://admin:admin@localhost:1978")))
47
48;; Just ensure the node exists so we don't get 500 internal server errors :)
49;; We will currently leave creation of an initial index up to the user....
50(define (ensure-qwiki-node-exists!)
51  (unless (any (lambda (n)
52                 (string=? (alist-ref 'name n) "qwiki"))
53               (list-nodes (search-server-uri)))
54    (create-search-node!)))
55
56(define (create-search-node!)
57  (add-node (search-server-uri) "qwiki"))
58
59;; Convert a wiki page to an estraier document plus attributes
60(define wiki-page->estraier-doc
61  (let ((contents-sxpath (sxpath '(// *text*)))
62        ;; TODO: Add more parsing to be able to obtain just the identifier?
63        ;; otherwise you would get bogus search results (we search in
64        ;; procedure arguments too, this way...)
65        (attribs-sxpath (sxpath '(// def sig *)))
66        (add-def! (lambda (key value alist)
67                    (let* ((old-item (alist-ref key alist eq? ""))
68                           (new-item (string-append old-item " " value))
69                           (old-ids (alist-ref 'identifier alist eq? ""))
70                           (new-ids (string-append old-ids " " value)))
71                      (alist-update! 'identifier new-ids
72                                     (alist-update! key new-item alist))))))
73    (lambda (doc)
74      (let loop ((items (attribs-sxpath doc))
75                 (attrs '()))
76        (if (null? items)
77            (values (contents-sxpath doc) (alist-delete! #f attrs))
78            (loop (cdr items)
79                  (add-def! (sxml:element-name (car items))
80                            (sxml:text (car items))
81                            attrs)))))))
82
83(define (update-search-entry! path page)
84  (ensure-qwiki-node-exists!)
85  (let*-values (((contents attribs) (wiki-page->estraier-doc page))
86                ((attribs) (alist-update! '@uri (string-join path "/") attribs)))
87    (put-document (search-server-uri) "qwiki" contents attribs)))
88
89(define (delete-search-entry! path)
90  (ensure-qwiki-node-exists!)
91  (condition-case
92      (delete-document (search-server-uri) "qwiki" uri: (string-join path "/"))
93    ((exn estraier-client args) (void)))) ;; Ignore already deleted entries
94
95(define search-rules
96  `((wiki-page
97     ((body
98       *preorder*
99       . ,(lambda (tag contents)
100            `(body (div (@ (id "search"))
101                        (form (@ (action "/search"))
102                              (div
103                               (label "free text"
104                                      (input (@ (type "text") (name "text"))))
105                               (label "identifier"
106                                      (input (@ (type "text") (name "ident"))))
107                               (input (@ (type "submit") (value "search")))
108                               (a (@ (href "/search-help")) "search help"))))
109                   . ,contents))))
110     . ,(lambda contents contents))
111    ,@alist-conv-rules*))
112
113(define (search-result-page text class p current-page page-count)
114  (cond
115   ((= p current-page)
116    `(li (@ (class ,(sprintf "~A current-page" class))) (span ,text)))
117   ((or (< p 0) (>= p page-count))
118    `(li (@ (class ,(sprintf "~A invalid-page" class))) (span ,text)))
119   (else
120    (let* ((uri (request-uri (current-request)))
121           (q (uri-query uri))
122           (q (alist-update! 'page p q))
123           (uri (update-uri uri query: q)))
124      `(li (@ (class ,class))
125           (a (@ (href ,(uri->string uri))
126                 (title ,(sprintf "View page ~A of ~A" (add1 p) page-count)))
127              ,text))))))
128
129(define (search request)
130  (ensure-qwiki-node-exists!)
131  (let* ((query (uri-query (request-uri request)))
132         ;; accept search like "procedure: foo" or just "foo"
133         (ident-m (irregex-match '(seq (* white) (submatch (+ graphic))
134                                       (* white) ":" (+ white)
135                                       (submatch (+ graphic)) (* white))
136                                 (alist-ref 'ident query eq? "")))
137         (type (if ident-m (irregex-match-substring ident-m 1) "identifier"))
138         (ident (if ident-m
139                    (irregex-match-substring ident-m 2)
140                    (string-trim-both (alist-ref 'ident query eq? ""))))
141         (attr-phrases (if (not (string-null? ident))
142                           (list (conc type " STRINC " ident))
143                           (list)))
144         (text (alist-ref 'text query eq? ""))
145         (phrase (if (string-null? (string-trim-both text))
146                     ;; Search for the identifier in main text so it shows
147                     ;; that text's context in the results (not perfect but
148                     ;; better than nothing)
149                     ident
150                     text))
151         (page (or (string->number (alist-ref 'page query eq? "0")) 0))
152         (page-size 10))
153    (receive (docs meta)
154      (find-documents (search-server-uri) "qwiki"
155                      phrase: phrase
156                      attr-phrases: attr-phrases
157                      max: page-size
158                      skip: (* page page-size))
159      (let* ((hit (alist-ref 'HIT meta))
160             (num-results (or (and hit (pair? hit) (string->number (car hit))) 0))
161             (num-pages (inexact->exact (floor (/ num-results page-size)))))
162       (send-content
163        `(wiki-page
164          (Header (title ,(sprintf "Search results for \"~A\"" phrase))
165                  . ,(if (qwiki-css-file)
166                         `((style ,(uri->string
167                                    (uri-relative-to (qwiki-css-file)
168                                                     (qwiki-base-uri)))))
169                         '()))
170          (body
171           (div (@ (id "search-results"))
172                (h1 ,(sprintf "Search results for \"~A\"" phrase))
173                ,(if (null? docs)
174                     `(p (@ (id "no-results-message"))
175                         "I'm terribly sorry, but I could not find anything "
176                         "to match your query. Please try a different query.")
177                     `(div (dl (@ (id "result-list"))
178                               . ,(map
179                                   (lambda (doc)
180                                     (let* ((matches (car doc))
181                                            (uri (alist-ref '@uri (cdr doc)))
182                                            (title (alist-ref '@title (cdr doc) eq? uri)))
183                                       `((dt (a (@ (href ,uri)) ,title))
184                                         (dd ,@(fold-right
185                                                (lambda (match info)
186                                                  (cond
187                                                   ((car match)
188                                                    `(#t ((em ,(car match))
189                                                          . ,(cadr info))))
190                                                   ((car info) ;; Still same snippet?
191                                                    `(#f (,(cdr match)
192                                                          . ,(cadr info))))
193                                                   (else
194                                                    `(#f (,(cdr match) " ... "
195                                                          . ,(cadr info))))))
196                                                '(#f ())
197                                                matches)))))
198                                   docs))
199                           ,@(if (> num-pages 1)
200                                 `((ol (@ (class "pager"))
201                                       ,(search-result-page
202                                         "Previous" "prev-page" (sub1 page)
203                                         page num-pages)
204                                       ,@(list-tabulate
205                                          num-pages
206                                          (lambda (p)
207                                            (search-result-page
208                                             (->string (add1 p)) "page-nr" p
209                                             page num-pages)))
210                                       ,(search-result-page
211                                         "Next" "next-page" (add1 page)
212                                         page num-pages)))
213                                 '())))))))))))
214
215(define (search-install!)
216  (qwiki-global-action-handlers (cons `(search . ,search)
217                                      (qwiki-global-action-handlers)))
218  (qwiki-extensions (cons search-rules (qwiki-extensions)))
219  (qwiki-update-handlers (cons update-search-entry! (qwiki-update-handlers)))
220  (qwiki-delete-handlers (cons delete-search-entry! (qwiki-delete-handlers))))
221
222)
Note: See TracBrowser for help on using the repository browser.