source: project/release/4/estraier-client/estraier-client.scm @ 15848

Last change on this file since 15848 was 15848, checked in by sjamaan, 10 years ago

Rename node-cache-usage to get-cache-usage for consistency

File size: 15.0 KB
Line 
1;;
2;; Hyper Estraier client library
3;;
4; Copyright (c) 2009, Peter Bex
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions
9; are met:
10;
11; 1. Redistributions of source code must retain the above copyright
12;    notice, this list of conditions and the following disclaimer.
13; 2. Redistributions in binary form must reproduce the above copyright
14;    notice, this list of conditions and the following disclaimer in the
15;    documentation and/or other materials provided with the distribution.
16; 3. Neither the name of the author nor the names of its
17;    contributors may be used to endorse or promote products derived
18;    from this software without specific prior written permission.
19;
20; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
24; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
25; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
26; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
29; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
31; OF THE POSSIBILITY OF SUCH DAMAGE.
32;
33; Please report bugs, suggestions and ideas to the Chicken Trac
34; ticket tracking system (assign tickets to user 'sjamaan'):
35; http://trac.callcc.org
36
37(module estraier-client
38  (get-node-info get-cache-usage optimize-node sync-node document-uri->id
39   list-documents put-document delete-document get-document
40   update-attributes document-attribute document-keywords find-documents
41   unregister-user register-admin-user register-guest-user
42   
43   ;; these could be useful on their own, so export them too
44   read-attributes read-draft write-attributes write-draft
45
46   shutdown-master sync-master backup-master rotate-log
47   list-nodes add-node delete-node clear-node list-users add-user delete-user)
48
49(import chicken scheme)
50(use data-structures extras ports srfi-1 srfi-13 http-client uri-common intarweb)
51
52;; Exhaust input port with web-server's output (yes, confusing) and return void
53(define (discard-output in)
54  (let loop ((line (read-line in)))
55    (if (eof-object? line) (void) (loop (read-line in)))))
56
57(define (exec uri writer reader)
58  ;; Estraier doesn't understand the preferred ";" separator
59  (parameterize ((form-urlencoded-separator "&"))
60    (call-with-input-request uri writer reader)))
61
62;; Read one block of data. The Hyper Estraier API sends data out in blocks
63;; separated by newlines.  The lines in the block are returned as a list
64(define (read-block inport)
65  (let loop ((result (list))
66             (line (read-line inport)))
67    (if (or (eof-object? line) (string-null? line))
68        (reverse! result)
69        (loop (cons line result) (read-line inport)))))
70
71(define (split-attrib-line attrib-line)
72  (let ((idx (string-index attrib-line #\=)))
73    (cons (string->symbol (string-take attrib-line idx))
74          (string-drop attrib-line (add1 idx)))))
75
76;; Helper procedure for checking that id xor uri is supplied
77(define (id/uri->alist id uri)
78  (cond
79   ((and id (not uri)) `((id . ,id)))
80   ((and uri (not id)) `((uri . ,uri)))
81   (else (error "You must supply either an id or a uri"))))
82
83;;;; Node API
84
85(define (node-uri base-uri node action . args)
86  (let* ((rel (update-uri (uri-reference "") path: (list "node" node action)))
87         (uri (if (uri-reference? base-uri)
88                  (uri-relative-to rel base-uri)
89                  (uri-relative-to rel (uri-reference base-uri)))))
90    (apply update-uri uri args)))
91
92(define (get-node-info base-uri node)
93  (exec
94   (node-uri base-uri node "inform")
95   #f
96   (lambda (in)
97     (let* ((db-info (string-split (car (read-block in)) "\t" #t))
98            (admins (read-block in))
99            (guests (read-block in)))
100       ;; According to the docs, there's more info after GUESTS but I can't
101       ;; seem to get this, so let's just read out just to be sure (for now)
102       (discard-output in)
103       `((name . ,(first db-info))
104         (label . ,(second db-info))
105         (document-count . ,(string->number (third db-info)))
106         (word-count . ,(string->number (fourth db-info)))
107         (size . ,(string->number (fifth db-info)))
108         (admin-users . ,admins)
109         (guest-users . ,guests))))))
110
111(define (get-cache-usage base-uri node)
112  (string->number (exec (node-uri base-uri node "cacheusage") #f read-line)))
113
114(define (optimize-node base-uri node)
115  (exec (node-uri base-uri node "optimize") #f discard-output))
116
117(define (sync-node base-uri node)
118  (exec (node-uri base-uri node "sync") #f discard-output))
119
120(define (list-documents base-uri node #!key max prev)
121  (exec (node-uri base-uri node "list" query: `((max . ,max) (prev . ,prev)))
122        #f
123        (lambda (in)
124          (map (lambda (line)
125                 (map cons
126                      `(@id @uri @digest @cdate @mdate @adate @title @author
127                            @type @lang @genre @size @weight @misc)
128                      (string-split line "\t" #t)))
129               (read-lines in)))))
130
131(define (write-attributes outport attributes)
132  (for-each (lambda (attrib)
133              (fprintf outport "~A=~A\r\n" (car attrib) (cdr attrib)))
134            attributes))
135
136;; Write out a document in "draft" format to the specified output port.
137(define (write-draft outport attributes contents)
138  (write-attributes outport attributes)
139  (fprintf outport "\r\n")
140  ;; What if there's a newline in the text?
141  (for-each (lambda (line) (fprintf outport "~A\r\n" line)) contents))
142
143(define (read-attributes inport)
144  (map split-attrib-line
145       ;; Remove control commands like %VECTOR for now
146       (filter (lambda (line)
147                 (string-index line #\=))
148               (read-block inport))))
149
150;; Read a document in "draft" format from the specified input port.
151(define (read-draft inport)
152  (let* ((metadata (read-attributes inport))
153         (document (read-lines inport)))
154    (values document metadata)))
155
156(define (put-document base-uri node contents attribs)
157  (exec
158   (make-request uri: (node-uri base-uri node "put_doc")
159                 method: 'POST major: 1 minor: 0
160                 headers: (headers '((content-type text/x-estraier-draft))))
161   (call-with-output-string ; use string because it wants content-length
162     ;; Can't write @digest because that would invalidate the document
163     (lambda (out) (write-draft out (alist-delete '@digest attribs) contents)))
164   discard-output))
165
166(define (delete-document base-uri node #!key id uri)
167  (exec (node-uri base-uri node "out_doc" query: (id/uri->alist id uri))
168        #f discard-output))
169
170(define (document-uri->id base-uri node uri)
171  (exec (node-uri base-uri node "uri_to_id"
172                  query: `((uri . ,uri))) #f read-line))
173
174(define (get-document base-uri node #!key id uri)
175  (apply values
176         (exec
177          (node-uri base-uri node "get_doc" query: (id/uri->alist id uri))
178          #f (lambda (in)
179               (call-with-values (lambda () (read-draft in)) list)))))
180
181;; This requires the new attributes plus all the old attribs, it
182;; simply replaces the document's attributes.  This also means it
183;; requires both @uri and @id!  Anything not present is reset or
184;; removed.  It's identical to put-document, except for the doc body.
185(define (update-attributes base-uri node attribs)
186  (exec
187   (make-request uri: (node-uri base-uri node "edit_doc")
188                 method: 'POST major: 1 minor: 0
189                 headers: (headers '((content-type text/x-estraier-draft))))
190   (call-with-output-string ; use string because it wants content-length
191     ;; Can't write @digest because that would invalidate the document
192     (lambda (out) (write-attributes out (alist-delete '@digest attribs))))
193   discard-output))
194
195(define (document-attribute base-uri node attrib #!key id uri)
196  (exec (node-uri base-uri node "get_doc_attr"
197                  query: (cons `(attr . ,attrib) (id/uri->alist id uri)))
198        #f read-line))
199
200(define (document-keywords base-uri node #!key id uri)
201  (exec (node-uri base-uri node "etch_doc" query: (id/uri->alist id uri))
202        #f
203        (lambda (in)
204          (let loop ((line (read-line in))
205                     (keywords (list)))
206            (if (eof-object? line)
207                (reverse! keywords) ;; preserve keyword document order
208                (let ((kwd/score (string-split line "\t" #t)))
209                  (loop (read-line in)
210                        (cons (cons (first kwd/score)
211                                    (string->number (second kwd/score)))
212                              keywords))))))))
213
214;; Attrs are ANDed together.  All attribute phrases must match
215(define (find-documents base-uri node #!key phrase (attr-phrases '())
216                        order max options auxiliary distinct depth
217                        wwidth hwidth awidth skip mask)
218  (when (> (length attr-phrases) 10)
219    (error (string-append "You can't provide more than 10 attribute phrases. "
220                          "This is a limitation of the estraier API. Sorry!")))
221  ;; Normalise attr-phrases list to attr, attr1, ... attr9
222  (let ((attrs (map (lambda (a i)
223                      (if (zero? i)
224                          (cons 'attr a)
225                          (cons (sprintf "attr~A" i) a)))
226                    attr-phrases
227                    (iota 10))))
228   (apply
229    values
230    (exec (node-uri base-uri node "search"
231                    query: `((phrase . ,phrase) (order . ,order)
232                             (max . ,max)       (options . ,options)
233                             (depth . ,depth)   (wwidth . ,wwidth)
234                             (hwidth . ,hwidth) (awidth . ,awidth)
235                             (skip . ,skip)     (mask . ,mask)
236                             (auxiliary . ,auxiliary)
237                             (distinct . ,distinct)
238                             ,@attrs))
239          #f
240          (lambda (in)
241            (let* ((delimiter (read-line in))
242                   (meta
243                    (let next-line ((line (read-line in))
244                                    (metadata (list)))
245                      ;; There's a pointless blank line at the end... skip over it
246                      (if (string-null? line)
247                          (next-line (read-line in) metadata)
248                          (if (string-prefix? delimiter line)
249                              (reverse! metadata) ; done, continue to snippets
250                              (let ((data (string-split line "\t" #t)))
251                                (next-line (read-line in)
252                                           (cons (cons (string->symbol (car data))
253                                                       (cdr data))
254                                                 metadata)))))))
255                   (documents
256                    (let next-document ((docs (list)))
257                      (let ((attribs (read-attributes in)))
258                        (let next-line ((matches (list))
259                                        (line  (read-line in)))
260                          (cond
261                           ;; We're not relying on :END here since it would
262                           ;; complicate matters with zero search results.
263                           ((eof-object? line)
264                            (reverse! docs))
265                           ((string-prefix? delimiter line)
266                            (next-document (cons (cons (reverse! matches) attribs)
267                                                 docs)))
268                           ;; Discard pointless empty lines.. there's at least
269                           ;; one at the end of each block.
270                           ((string-null? line)
271                            (next-line matches (read-line in)))
272                           (else
273                            (let* ((idx (string-index line #\tab))
274                                   (highlight (and idx (string-take line idx)))
275                                   (match (if idx
276                                              (string-drop line (add1 idx))
277                                              line)))
278                              (next-line (cons (cons highlight match) matches)
279                                         (read-line in))))))))))
280              (list documents meta)))))))
281
282(define (_set-user base-uri node name mode)
283  (exec (node-uri base-uri node "_set_user"
284                  query: `((name . ,name) (mode . ,mode)))
285        #f read-lines))
286
287(define (unregister-user base-uri node name)
288  (_set-user base-uri node name 0))
289
290(define (register-admin-user base-uri node name)
291  (_set-user base-uri node name 1))
292
293(define (register-guest-user base-uri node name)
294  (_set-user base-uri node name 2))
295
296;; TODO: _set_link
297
298;;;; Master API
299
300(define (master-uri base-uri action . args)
301  (let ((uri (if (uri-reference? base-uri)
302                 (apply update-uri base-uri args)
303                 (apply update-uri (uri-reference base-uri) args))))
304    (update-uri uri
305                path: (append (uri-path uri) (list "master"))
306                query: (alist-update! 'action action (uri-query uri)))))
307
308(define (shutdown-master base-uri)
309  (exec (master-uri base-uri "shutdown") #f discard-output))
310
311(define (sync-master base-uri)
312  (exec (master-uri base-uri "sync") #f discard-output))
313
314(define (backup-master base-uri)
315  (exec (master-uri base-uri "backup") #f discard-output))
316
317(define (rotate-log base-uri)
318  (exec (master-uri base-uri "logrtt") #f discard-output))
319
320(define (list-nodes base-uri)
321  (map (lambda (line)
322         (string-split line "\t" #t))
323       (exec (master-uri base-uri "nodelist") #f read-lines)))
324
325(define (add-node base-uri node-name #!optional node-label)
326  (exec (master-uri base-uri "nodeadd"
327                    query: `((name . ,node-name) (label . ,node-label)))
328        #f discard-output))
329
330(define (delete-node base-uri node-name)
331  (exec (master-uri base-uri "nodedel" query: `((name . ,node-name)))
332        #f discard-output))
333
334(define (clear-node base-uri node-name)
335  (exec (master-uri base-uri "nodeclr" query: `((name . ,node-name)))
336        #f discard-output))
337
338(define (list-users base-uri)
339  (exec (master-uri base-uri "userlist")
340        #f
341        (lambda (in)
342          (let loop ((line (read-line in))
343                     (lines (list)))
344            (if (eof-object? line)
345                (reverse! lines)
346                (loop (read-line in)
347                      (cons (string-split line "\t" #t) lines)))))))
348
349(define (add-user base-uri username password
350                  #!key flags fullname description)
351  (exec (make-request uri: (master-uri base-uri "useradd")
352                      method: 'POST major: 1 minor: 0)
353        `((name . ,username) (passwd . ,password)
354          (flags . ,flags) (fname . ,fullname) (misc . ,description))
355        discard-output))
356
357(define (delete-user base-uri username)
358  (exec (master-uri base-uri "userdel" query: `((name . ,username)))
359        #f discard-output))
360
361)
Note: See TracBrowser for help on using the repository browser.