;; ;; Hyper Estraier client library ;; ; Copyright (c) 2009-2012 Peter Bex ; All rights reserved. ; ; Redistribution and use in source and binary forms, with or without ; modification, are permitted provided that the following conditions ; are met: ; ; 1. Redistributions of source code must retain the above copyright ; notice, this list of conditions and the following disclaimer. ; 2. 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. ; 3. Neither the name of the author 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 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 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. ; ; Please report bugs, suggestions and ideas to the Chicken Trac ; ticket tracking system (assign tickets to user 'sjamaan'): ; http://trac.callcc.org (module estraier-client (get-node-info get-cache-usage optimize-node sync-node document-uri->id list-documents put-document delete-document get-document update-attributes document-attribute document-keywords find-documents unregister-user register-admin-user register-guest-user ;; these could be useful on their own, so export them too read-attributes read-draft write-attributes write-draft shutdown-master sync-all-nodes backup-master rotate-log list-nodes add-node delete-node clear-node list-users add-user delete-user) (import chicken scheme) (use data-structures extras ports srfi-1 srfi-13 http-client uri-common intarweb) ;; Exhaust input port with web-server's output (yes, confusing) and return void (define (discard-output in) (let loop ((line (read-line in))) (if (eof-object? line) (void) (loop (read-line in))))) (define (estraier-exn loc message specific . rest) (make-composite-condition (make-property-condition 'exn 'location loc 'message message) (make-property-condition 'estraier-client) (apply make-property-condition specific rest))) (define (http->estraier-exn exn loc specific . rest) (let ((msg ((condition-property-accessor 'exn 'message) exn))) (apply estraier-exn loc msg specific rest))) (define (exec loc uri writer reader) (condition-case (receive (result . _) (call-with-input-request uri writer reader) result) (exn (client-error) (case (response-code ((condition-property-accessor 'client-error 'response) exn)) ((400) (signal (http->estraier-exn exn loc 'args))) ((401) (signal (http->estraier-exn exn loc 'auth))) ((403) (signal (http->estraier-exn exn loc 'perm))) ((404) (signal (http->estraier-exn exn loc 'node))) (else (signal exn)))) (exn (server-error) (case (response-code ((condition-property-accessor 'client-error 'response) exn)) ((500) (signal (http->estraier-exn exn loc 'server))) (else (signal exn)))))) ;; Read one block of data. The Hyper Estraier API sends data out in blocks ;; separated by newlines. The lines in the block are returned as a list (define (read-block inport) (let loop ((result (list)) (line (read-line inport))) (if (or (eof-object? line) (string-null? line)) (reverse! result) (loop (cons line result) (read-line inport))))) (define (split-attrib-line attrib-line) (let ((idx (string-index attrib-line #\=))) (cons (string->symbol (string-take attrib-line idx)) (string-drop attrib-line (add1 idx))))) (define (line->node-info line) (let ((info (string-split line "\t" #t))) `((name . ,(first info)) (label . ,(second info)) (document-count . ,(string->number (third info))) (word-count . ,(string->number (fourth info))) (size . ,(string->number (fifth info)))))) (define (line->user-info line) (let ((info (string-split line "\t" #t))) (map cons '(name password flags fullname misc) info))) ;; Flatten all whitespace types to one regular whitespace. Draft syntax ;; assigns special meaning to tabs/newlines but has no way to escape that. (define (kill-special-whitespace str) (string-translate str "\t\n\r" " ")) (define (write-attributes outport attributes) (for-each (lambda (attrib) (fprintf outport "~A=~A\r\n" (kill-special-whitespace (->string (car attrib))) (kill-special-whitespace (->string (cdr attrib))))) attributes)) ;; Write out a document in "draft" format to the specified output port. (define (write-draft outport contents attributes) (write-attributes outport attributes) (fprintf outport "\r\n") (for-each (lambda (line) (fprintf outport "~A\r\n" (kill-special-whitespace line))) contents)) (define (read-attributes inport) (map split-attrib-line ;; Remove control commands like %VECTOR for now (filter (lambda (line) (string-index line #\=)) (read-block inport)))) ;; Read a document in "draft" format from the specified input port. (define (read-draft inport) (let* ((metadata (read-attributes inport)) (document (read-lines inport))) (values document metadata))) ;; Helper procedure for checking that id xor uri is supplied (define (id/uri->alist loc id uri) (cond ((and id (not uri)) `((id . ,id))) ((and uri (not id)) `((uri . ,uri))) (else (signal (estraier-exn loc "You must supply either an id or a uri" 'args))))) ;;;; Node API (define (node-uri base-uri node action . args) ;; Estraier doesn't understand the preferred ";" separator (parameterize ((form-urlencoded-separator "&")) (let* ((rel (update-uri (uri-reference "") path: (list "node" node action))) (uri (if (uri-reference? base-uri) (uri-relative-to rel base-uri) (uri-relative-to rel (uri-reference base-uri))))) (apply update-uri uri args)))) (define (get-node-info base-uri node) (exec 'get-node-info (node-uri base-uri node "inform") #f (lambda (in) (let* ((node-info (line->node-info (car (read-block in)))) (admins (read-block in)) (guests (read-block in))) ;; According to the docs, there's more info after GUESTS but I can't ;; seem to get this, so let's just read out just to be sure (for now) (discard-output in) `(,@node-info (admin-users . ,admins) (guest-users . ,guests)))))) (define (get-cache-usage base-uri node) (string->number (exec 'get-cache-usage (node-uri base-uri node "cacheusage") #f read-line))) (define (optimize-node base-uri node) (exec 'optimize-node (node-uri base-uri node "optimize") #f discard-output)) (define (sync-node base-uri node) (exec 'sync-node (node-uri base-uri node "sync") #f discard-output)) (define (list-documents base-uri node #!key max prev) (exec 'list-documents (node-uri base-uri node "list" query: `((max . ,max) (prev . ,prev))) #f (lambda (in) (map (lambda (line) (map cons `(@id @uri @digest @cdate @mdate @adate @title @author @type @lang @genre @size @weight @misc) (string-split line "\t" #t))) (read-lines in))))) (define (put-document base-uri node contents attribs) (exec 'put-document (make-request uri: (node-uri base-uri node "put_doc") method: 'POST major: 1 minor: 0 headers: (headers '((content-type text/x-estraier-draft)))) (call-with-output-string ; use string because it wants content-length ;; Can't write @digest because that would invalidate the document (lambda (out) (write-draft out contents (alist-delete '@digest attribs)))) discard-output)) (define (delete-document base-uri node #!key id uri) (exec 'delete-document (node-uri base-uri node "out_doc" query: (id/uri->alist 'delete-document id uri)) #f discard-output)) (define (document-uri->id base-uri node uri) (exec 'document-uri->id (node-uri base-uri node "uri_to_id" query: `((uri . ,uri))) #f read-line)) (define (get-document base-uri node #!key id uri) (apply values (exec 'get-document (node-uri base-uri node "get_doc" query: (id/uri->alist 'get-document id uri)) #f (lambda (in) (call-with-values (lambda () (read-draft in)) list))))) ;; This requires the new attributes plus all the old attribs, it ;; simply replaces the document's attributes. This also means it ;; requires both @uri and @id! Anything not present is reset or ;; removed. It's identical to put-document, except for the doc body. (define (update-attributes base-uri node attribs) (exec 'update-attributes (make-request uri: (node-uri base-uri node "edit_doc") method: 'POST major: 1 minor: 0 headers: (headers '((content-type text/x-estraier-draft)))) (call-with-output-string ; use string because it wants content-length ;; Can't write @digest because that would invalidate the document (lambda (out) (write-attributes out (alist-delete '@digest attribs)))) discard-output)) (define (document-attribute base-uri node attrib #!key id uri) (exec 'document-attribute (node-uri base-uri node "get_doc_attr" query: (cons `(attr . ,attrib) (id/uri->alist 'document-attribute id uri))) #f read-line)) (define (document-keywords base-uri node #!key id uri) (exec 'document-keywords (node-uri base-uri node "etch_doc" query: (id/uri->alist 'document-keywords id uri)) #f (lambda (in) (let loop ((line (read-line in)) (keywords (list))) (if (eof-object? line) (reverse! keywords) ;; preserve keyword document order (let ((kwd/score (string-split line "\t" #t))) (loop (read-line in) (cons (cons (first kwd/score) (string->number (second kwd/score))) keywords)))))))) ;; Attrs are ANDed together. All attribute phrases must match (define (find-documents base-uri node #!key phrase (attr-phrases '()) order max options auxiliary distinct depth wwidth hwidth awidth skip mask) (when (> (length attr-phrases) 10) (signal (estraier-exn 'find-documents (conc "You can't provide more than 10 attribute phrases. " "This is a limitation of the estraier API. Sorry!") 'args))) ;; Normalise attr-phrases list to attr, attr1, ... attr9 (let ((attrs (map (lambda (a i) (if (zero? i) (cons 'attr a) (cons (sprintf "attr~A" i) a))) attr-phrases (iota 10)))) (apply values (exec 'find-documents (node-uri base-uri node "search" query: `((phrase . ,phrase) (order . ,order) (max . ,max) (options . ,options) (depth . ,depth) (wwidth . ,wwidth) (hwidth . ,hwidth) (awidth . ,awidth) (skip . ,skip) (mask . ,mask) (auxiliary . ,auxiliary) (distinct . ,distinct) ,@attrs)) #f (lambda (in) (let* ((delimiter (read-line in)) (meta (let next-line ((line (read-line in)) (metadata (list))) ;; There's a pointless blank line at the end... skip over it (if (string-null? line) (next-line (read-line in) metadata) (if (string-prefix? delimiter line) (reverse! metadata) ; done, continue to snippets (let ((data (string-split line "\t" #t))) (next-line (read-line in) (cons (cons (string->symbol (car data)) (cdr data)) metadata))))))) (documents (let next-document ((docs (list))) (let ((attribs (read-attributes in))) (let next-line ((matches (list)) (line (read-line in))) (cond ;; We're not relying on :END here since it would ;; complicate matters with zero search results. ((eof-object? line) (reverse! docs)) ((string-prefix? delimiter line) (next-document (cons (cons (reverse! matches) attribs) docs))) ;; Discard pointless empty lines.. there's at least ;; one at the end of each block. ((string-null? line) (next-line matches (read-line in))) (else (let* ((idx (string-index line #\tab)) (highlight (and idx (string-take line idx))) (match (if idx (string-drop line (add1 idx)) line))) (next-line (cons (cons highlight match) matches) (read-line in)))))))))) (list documents meta))))))) (define (_set-user loc base-uri node name mode) (exec loc (node-uri base-uri node "_set_user" query: `((name . ,name) (mode . ,mode))) #f discard-output)) (define (unregister-user base-uri node name) (_set-user 'unregister-user base-uri node name 0)) (define (register-admin-user base-uri node name) (_set-user 'register-admin-user base-uri node name 1)) (define (register-guest-user base-uri node name) (_set-user 'register-guest-user base-uri node name 2)) ;; TODO: _set_link ;;;; Master API (define (master-uri base-uri action . args) ;; Estraier doesn't understand the preferred ";" separator (parameterize ((form-urlencoded-separator "&")) (let ((uri (if (uri-reference? base-uri) (apply update-uri base-uri args) (apply update-uri (uri-reference base-uri) args)))) (update-uri (uri-relative-to (uri-reference "./master") uri) query: (alist-update! 'action action (uri-query uri)))))) (define (shutdown-master base-uri) (exec 'shutdown-master (master-uri base-uri "shutdown") #f discard-output)) (define (sync-all-nodes base-uri) (exec 'sync-all-nodes (master-uri base-uri "sync") #f discard-output)) (define (backup-master base-uri) (exec 'backup-master (master-uri base-uri "backup") #f discard-output)) (define (rotate-log base-uri) (exec 'rotate-log (master-uri base-uri "logrtt") #f discard-output)) (define (list-nodes base-uri) (map line->node-info (exec 'list-nodes (master-uri base-uri "nodelist") #f read-lines))) (define (add-node base-uri node-name #!optional node-label) (exec 'add-node (master-uri base-uri "nodeadd" query: `((name . ,node-name) (label . ,node-label))) #f discard-output)) (define (delete-node base-uri node-name) (exec 'delete-node (master-uri base-uri "nodedel" query: `((name . ,node-name))) #f discard-output)) (define (clear-node base-uri node-name) (exec 'clear-node (master-uri base-uri "nodeclr" query: `((name . ,node-name))) #f discard-output)) (define (list-users base-uri) (exec 'list-users (master-uri base-uri "userlist") #f (lambda (in) (map line->user-info (read-lines in))))) (define (add-user base-uri username password #!key flags fullname misc) (exec 'add-user (make-request uri: (master-uri base-uri "useradd") method: 'POST major: 1 minor: 0) `((name . ,username) (passwd . ,password) (flags . ,flags) (fname . ,fullname) (misc . ,misc)) discard-output)) (define (delete-user base-uri username) (exec 'delete-user (master-uri base-uri "userdel" query: `((name . ,username))) #f discard-output)) )