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

Last change on this file since 26887 was 26887, checked in by sjamaan, 8 years ago

qwiki: Only show pager when there are more than 1 pages ;)

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)
43(require-library regex)
44(import irregex)
45
46(define search-server-uri
47  (make-parameter (or (get-environment-variable "QWIKI_SEARCH_URI")
48                      "http://admin:admin@localhost:1978")))
49
50;; Just ensure the node exists so we don't get 500 internal server errors :)
51;; We will currently leave creation of an initial index up to the user....
52(define (ensure-qwiki-node-exists!)
53  (unless (any (lambda (n)
54                 (string=? (alist-ref 'name n) "qwiki"))
55               (list-nodes (search-server-uri)))
56    (create-search-node!)))
57
58(define (create-search-node!)
59  (add-node (search-server-uri) "qwiki"))
60
61;; Convert a wiki page to an estraier document plus attributes
62(define wiki-page->estraier-doc
63  (let ((contents-sxpath (sxpath '(// *text*)))
64        ;; TODO: Add more parsing to be able to obtain just the identifier?
65        ;; otherwise you would get bogus search results (we search in
66        ;; procedure arguments too, this way...)
67        (attribs-sxpath (sxpath '(// def sig *)))
68        (add-def! (lambda (key value alist)
69                    (let* ((old-item (alist-ref key alist eq? ""))
70                           (new-item (string-append old-item " " value))
71                           (old-ids (alist-ref 'identifier alist eq? ""))
72                           (new-ids (string-append old-ids " " value)))
73                      (alist-update! 'identifier new-ids
74                                     (alist-update! key new-item alist))))))
75    (lambda (doc)
76      (let loop ((items (attribs-sxpath doc))
77                 (attrs '()))
78        (if (null? items)
79            (values (contents-sxpath doc) (alist-delete! #f attrs))
80            (loop (cdr items)
81                  (add-def! (sxml:element-name (car items))
82                            (sxml:text (car items))
83                            attrs)))))))
84
85(define (update-search-entry! path page)
86  (ensure-qwiki-node-exists!)
87  (let*-values (((contents attribs) (wiki-page->estraier-doc page))
88                ((attribs) (alist-update! '@uri (string-join path "/") attribs)))
89    (put-document (search-server-uri) "qwiki" contents attribs)))
90
91(define (delete-search-entry! path)
92  (ensure-qwiki-node-exists!)
93  (condition-case
94      (delete-document (search-server-uri) "qwiki" uri: (string-join path "/"))
95    ((exn estraier-client args) (void)))) ;; Ignore already deleted entries
96
97(define search-rules
98  `((wiki-page
99     ((body
100       *preorder*
101       . ,(lambda (tag contents)
102            `(body (div (@ (id "search"))
103                        (form (@ (action "/search"))
104                              (div
105                               (label "free text"
106                                      (input (@ (type "text") (name "text"))))
107                               (label "identifier"
108                                      (input (@ (type "text") (name "ident"))))
109                               (input (@ (type "submit") (value "search")))
110                               (a (@ (href "/search-help")) "search help"))))
111                   . ,contents))))
112     . ,(lambda contents contents))
113    ,@alist-conv-rules*))
114
115(define (search-result-page text class p current-page page-count)
116  (cond
117   ((= p current-page)
118    `(li (@ (class ,(sprintf "~A current-page" class))) (span ,text)))
119   ((or (< p 0) (>= p page-count))
120    `(li (@ (class ,(sprintf "~A invalid-page" class))) (span ,text)))
121   (else
122    (let* ((uri (request-uri (current-request)))
123           (q (uri-query uri))
124           (q (alist-update! 'page p q))
125           (uri (update-uri uri query: q)))
126      `(li (@ (class ,class))
127           (a (@ (href ,(uri->string uri))
128                 (title ,(sprintf "View page ~A of ~A" (add1 p) page-count)))
129              ,text))))))
130
131(define (search request)
132  (ensure-qwiki-node-exists!)
133  (let* ((query (uri-query (request-uri request)))
134         ;; accept search like "procedure: foo" or just "foo"
135         (ident-m (irregex-match '(seq (* white) (submatch (+ graphic))
136                                       (* white) ":" (+ white)
137                                       (submatch (+ graphic)) (* white))
138                                 (alist-ref 'ident query eq? "")))
139         (type (if ident-m (irregex-match-substring ident-m 1) "identifier"))
140         (ident (if ident-m
141                    (irregex-match-substring ident-m 2)
142                    (string-trim-both (alist-ref 'ident query eq? ""))))
143         (attr-phrases (if (not (string-null? ident))
144                           (list (conc type " STRINC " ident))
145                           (list)))
146         (text (alist-ref 'text query eq? ""))
147         (phrase (if (string-null? (string-trim-both text))
148                     ;; Search for the identifier in main text so it shows
149                     ;; that text's context in the results (not perfect but
150                     ;; better than nothing)
151                     ident
152                     text))
153         (page (or (string->number (alist-ref 'page query eq? "0")) 0))
154         (page-size 10))
155    (receive (docs meta)
156      (find-documents (search-server-uri) "qwiki"
157                      phrase: phrase
158                      attr-phrases: attr-phrases
159                      max: page-size
160                      skip: (* page page-size))
161      (let* ((hit (alist-ref 'HIT meta))
162             (num-results (or (and hit (pair? hit) (string->number (car hit))) 0))
163             (num-pages (inexact->exact (floor (/ num-results page-size)))))
164       (send-content
165        `(wiki-page
166          (Header (title ,(sprintf "Search results for \"~A\"" phrase))
167                  . ,(if (qwiki-css-file)
168                         `((style ,(uri->string
169                                    (uri-relative-to (qwiki-css-file)
170                                                     (qwiki-base-uri)))))
171                         '()))
172          (body
173           (div (@ (id "search-results"))
174                (h1 ,(sprintf "Search results for \"~A\"" phrase))
175                ,(if (null? docs)
176                     `(p (@ (id "no-results-message"))
177                         "I'm terribly sorry, but I could not find anything "
178                         "to match your query. Please try a different query.")
179                     `(div (dl (@ (id "result-list"))
180                               . ,(map
181                                   (lambda (doc)
182                                     (let* ((matches (car doc))
183                                            (uri (alist-ref '@uri (cdr doc)))
184                                            (title (alist-ref '@title (cdr doc) eq? uri)))
185                                       `((dt (a (@ (href ,uri)) ,title))
186                                         (dd ,@(fold-right
187                                                (lambda (match info)
188                                                  (cond
189                                                   ((car match)
190                                                    `(#t ((em ,(car match))
191                                                          . ,(cadr info))))
192                                                   ((car info) ;; Still same snippet?
193                                                    `(#f (,(cdr match)
194                                                          . ,(cadr info))))
195                                                   (else
196                                                    `(#f (,(cdr match) " ... "
197                                                          . ,(cadr info))))))
198                                                '(#f ())
199                                                matches)))))
200                                   docs))
201                           ,@(if (> num-pages 1)
202                                 `((ol (@ (class "pager"))
203                                       ,(search-result-page
204                                         "Previous" "prev-page" (sub1 page)
205                                         page num-pages)
206                                       ,@(list-tabulate
207                                          num-pages
208                                          (lambda (p)
209                                            (search-result-page
210                                             (->string (add1 p)) "page-nr" p
211                                             page num-pages)))
212                                       ,(search-result-page
213                                         "Next" "next-page" (add1 page)
214                                         page num-pages)))
215                                 '())))))))))))
216
217(define (search-install!)
218  (qwiki-global-action-handlers (cons `(search . ,search)
219                                      (qwiki-global-action-handlers)))
220  (qwiki-extensions (cons search-rules (qwiki-extensions)))
221  (qwiki-update-handlers (cons update-search-entry! (qwiki-update-handlers)))
222  (qwiki-delete-handlers (cons delete-search-entry! (qwiki-delete-handlers))))
223
224)
Note: See TracBrowser for help on using the repository browser.