;; ;; qwiki-search - search extension for qwiki ;; ;; Copyright (c) 2009-2012 Peter Bex ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above ;; copyright notice, this list of conditions and the following ;; disclaimer in the documentation and/or other materials provided ;; with the distribution. ;; ;; - Neither name of the copyright holders nor the names of its ;; contributors may be used to endorse or promote products derived ;; from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, ;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF ;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE ;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF ;; USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED ;; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ;; POSSIBILITY OF SUCH DAMAGE. (module qwiki-search (create-search-node! search-install! search-server-uri wiki-page->estraier-doc) (import chicken scheme) (use data-structures extras srfi-1 srfi-13 intarweb uri-common spiffy qwiki qwiki-sxml sxml-transforms sxpath sxpath-lolevel estraier-client) (require-library regex) (import irregex) (define search-server-uri (make-parameter (or (get-environment-variable "QWIKI_SEARCH_URI") "http://admin:admin@localhost:1978"))) ;; Just ensure the node exists so we don't get 500 internal server errors :) ;; We will currently leave creation of an initial index up to the user.... (define (ensure-qwiki-node-exists!) (unless (any (lambda (n) (string=? (alist-ref 'name n) "qwiki")) (list-nodes (search-server-uri))) (create-search-node!))) (define (create-search-node!) (add-node (search-server-uri) "qwiki")) ;; Convert a wiki page to an estraier document plus attributes (define wiki-page->estraier-doc (let ((contents-sxpath (sxpath '(// *text*))) ;; TODO: Add more parsing to be able to obtain just the identifier? ;; otherwise you would get bogus search results (we search in ;; procedure arguments too, this way...) (attribs-sxpath (sxpath '(// def sig *))) (add-def! (lambda (key value alist) (let* ((old-item (alist-ref key alist eq? "")) (new-item (string-append old-item " " value)) (old-ids (alist-ref 'identifier alist eq? "")) (new-ids (string-append old-ids " " value))) (alist-update! 'identifier new-ids (alist-update! key new-item alist)))))) (lambda (doc) (let loop ((items (attribs-sxpath doc)) (attrs '())) (if (null? items) (values (contents-sxpath doc) (alist-delete! #f attrs)) (loop (cdr items) (add-def! (sxml:element-name (car items)) (sxml:text (car items)) attrs))))))) (define (update-search-entry! path page) (ensure-qwiki-node-exists!) (let*-values (((contents attribs) (wiki-page->estraier-doc page)) ((attribs) (alist-update! '@uri (string-join path "/") attribs))) (put-document (search-server-uri) "qwiki" contents attribs))) (define (delete-search-entry! path) (ensure-qwiki-node-exists!) (condition-case (delete-document (search-server-uri) "qwiki" uri: (string-join path "/")) ((exn estraier-client args) (void)))) ;; Ignore already deleted entries (define search-rules `((wiki-page ((body *preorder* . ,(lambda (tag contents) `(body (div (@ (id "search")) (form (@ (action "/search")) (div (label "free text" (input (@ (type "text") (name "text")))) (label "identifier" (input (@ (type "text") (name "ident")))) (input (@ (type "submit") (value "search"))) (a (@ (href "/search-help")) "search help")))) . ,contents)))) . ,(lambda contents contents)) ,@alist-conv-rules*)) (define (search-result-page text class p current-page page-count) (cond ((= p current-page) `(li (@ (class ,(sprintf "~A current-page" class))) (span ,text))) ((or (< p 0) (>= p page-count)) `(li (@ (class ,(sprintf "~A invalid-page" class))) (span ,text))) (else (let* ((uri (request-uri (current-request))) (q (uri-query uri)) (q (alist-update! 'page p q)) (uri (update-uri uri query: q))) `(li (@ (class ,class)) (a (@ (href ,(uri->string uri)) (title ,(sprintf "View page ~A of ~A" (add1 p) page-count))) ,text)))))) (define (search request) (ensure-qwiki-node-exists!) (let* ((query (uri-query (request-uri request))) ;; accept search like "procedure: foo" or just "foo" (ident-m (irregex-match '(seq (* white) (submatch (+ graphic)) (* white) ":" (+ white) (submatch (+ graphic)) (* white)) (alist-ref 'ident query eq? ""))) (type (if ident-m (irregex-match-substring ident-m 1) "identifier")) (ident (if ident-m (irregex-match-substring ident-m 2) (string-trim-both (alist-ref 'ident query eq? "")))) (attr-phrases (if (not (string-null? ident)) (list (conc type " STRINC " ident)) (list))) (text (alist-ref 'text query eq? "")) (phrase (if (string-null? (string-trim-both text)) ;; Search for the identifier in main text so it shows ;; that text's context in the results (not perfect but ;; better than nothing) ident text)) (page (or (string->number (alist-ref 'page query eq? "0")) 0)) (page-size 10)) (receive (docs meta) (find-documents (search-server-uri) "qwiki" phrase: phrase attr-phrases: attr-phrases max: page-size skip: (* page page-size)) (let* ((hit (alist-ref 'HIT meta)) (num-results (or (and hit (pair? hit) (string->number (car hit))) 0)) (num-pages (inexact->exact (floor (/ num-results page-size))))) (send-content `(wiki-page (Header (title ,(sprintf "Search results for \"~A\"" phrase)) . ,(if (qwiki-css-file) `((style ,(uri->string (uri-relative-to (qwiki-css-file) (qwiki-base-uri))))) '())) (body (div (@ (id "search-results")) (h1 ,(sprintf "Search results for \"~A\"" phrase)) ,(if (null? docs) `(p (@ (id "no-results-message")) "I'm terribly sorry, but I could not find anything " "to match your query. Please try a different query.") `(div (dl (@ (id "result-list")) . ,(map (lambda (doc) (let* ((matches (car doc)) (uri (alist-ref '@uri (cdr doc))) (title (alist-ref '@title (cdr doc) eq? uri))) `((dt (a (@ (href ,uri)) ,title)) (dd ,@(fold-right (lambda (match info) (cond ((car match) `(#t ((em ,(car match)) . ,(cadr info)))) ((car info) ;; Still same snippet? `(#f (,(cdr match) . ,(cadr info)))) (else `(#f (,(cdr match) " ... " . ,(cadr info)))))) '(#f ()) matches))))) docs)) ,@(if (> num-pages 1) `((ol (@ (class "pager")) ,(search-result-page "Previous" "prev-page" (sub1 page) page num-pages) ,@(list-tabulate num-pages (lambda (p) (search-result-page (->string (add1 p)) "page-nr" p page num-pages))) ,(search-result-page "Next" "next-page" (add1 page) page num-pages))) '()))))))))))) (define (search-install!) (qwiki-global-action-handlers (cons `(search . ,search) (qwiki-global-action-handlers))) (qwiki-extensions (cons search-rules (qwiki-extensions))) (qwiki-update-handlers (cons update-search-entry! (qwiki-update-handlers))) (qwiki-delete-handlers (cons delete-search-entry! (qwiki-delete-handlers)))) )