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

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

Make list-nodes return node info in an alist so it looks more like get-node-info

File size: 17.2 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 regex srfi-1 srfi-13
51     http-client uri-common intarweb)
52
53;; Exhaust input port with web-server's output (yes, confusing) and return void
54(define (discard-output in)
55  (let loop ((line (read-line in)))
56    (if (eof-object? line) (void) (loop (read-line in)))))
57
58(define (estraier-exn loc message specific . rest)
59  (make-composite-condition
60   (make-property-condition 'exn 'location loc 'message message)
61   (make-property-condition 'estraier-client)
62   (apply make-property-condition specific rest)))
63
64(define (http->estraier-exn exn loc specific . rest)
65  (estraier-exn loc ((condition-property-accessor 'exn 'message) exn)))
66
67(define (exec loc uri writer reader)
68  (condition-case
69      ;; Estraier doesn't understand the preferred ";" separator
70      (parameterize ((form-urlencoded-separator "&"))
71        (call-with-input-request uri writer reader))
72    (exn (client-error)
73         (case (response-code
74                ((condition-property-accessor 'client-error 'response) exn))
75           ((400) (signal (http->estraier-exn exn loc 'args)))
76           ((401) (signal (http->estraier-exn exn loc 'auth)))
77           ((403) (signal (http->estraier-exn exn loc 'perm)))
78           ((404) (signal (http->estraier-exn exn loc 'node)))
79           (else  (signal exn))))
80    (exn (server-error)
81         (case (response-code
82                ((condition-property-accessor 'client-error 'response) exn))
83           ((500) (signal (http->estraier-exn exn loc 'server)))
84           (else  (signal exn))))))
85
86;; Read one block of data. The Hyper Estraier API sends data out in blocks
87;; separated by newlines.  The lines in the block are returned as a list
88(define (read-block inport)
89  (let loop ((result (list))
90             (line (read-line inport)))
91    (if (or (eof-object? line) (string-null? line))
92        (reverse! result)
93        (loop (cons line result) (read-line inport)))))
94
95(define (split-attrib-line attrib-line)
96  (let ((idx (string-index attrib-line #\=)))
97    (cons (string->symbol (string-take attrib-line idx))
98          (string-drop attrib-line (add1 idx)))))
99
100(define (line->node-info line)
101  (let ((info (string-split line "\t" #t)))
102    `((name . ,(first info))
103      (label . ,(second info))
104      (document-count . ,(string->number (third info)))
105      (word-count . ,(string->number (fourth info)))
106      (size . ,(string->number (fifth info))))))
107
108;; Flatten all whitespace types to one regular whitespace.  Draft syntax
109;; assigns special meaning to tabs/newlines but has no way to escape that.
110(define (kill-special-whitespace str)
111  (string-substitute '(+ whitespace) " " str))
112
113(define (write-attributes outport attributes)
114  (for-each (lambda (attrib)
115              (fprintf outport "~A=~A\r\n"
116                       (kill-special-whitespace (->string (car attrib)))
117                       (kill-special-whitespace (->string (cdr attrib)))))
118            attributes))
119
120;; Write out a document in "draft" format to the specified output port.
121(define (write-draft outport attributes contents)
122  (write-attributes outport attributes)
123  (fprintf outport "\r\n")
124  (for-each (lambda (line)
125              (fprintf outport "~A\r\n" (kill-special-whitespace line)))
126            contents))
127
128(define (read-attributes inport)
129  (map split-attrib-line
130       ;; Remove control commands like %VECTOR for now
131       (filter (lambda (line)
132                 (string-index line #\=))
133               (read-block inport))))
134
135;; Read a document in "draft" format from the specified input port.
136(define (read-draft inport)
137  (let* ((metadata (read-attributes inport))
138         (document (read-lines inport)))
139    (values document metadata)))
140
141;; Helper procedure for checking that id xor uri is supplied
142(define (id/uri->alist loc id uri)
143  (cond
144   ((and id (not uri)) `((id . ,id)))
145   ((and uri (not id)) `((uri . ,uri)))
146   (else
147    (signal (estraier-exn loc "You must supply either an id or a uri" 'args)))))
148
149;;;; Node API
150
151(define (node-uri base-uri node action . args)
152  (let* ((rel (update-uri (uri-reference "") path: (list "node" node action)))
153         (uri (if (uri-reference? base-uri)
154                  (uri-relative-to rel base-uri)
155                  (uri-relative-to rel (uri-reference base-uri)))))
156    (apply update-uri uri args)))
157
158(define (get-node-info base-uri node)
159  (exec
160   'get-node-info
161   (node-uri base-uri node "inform")
162   #f
163   (lambda (in)
164     (let* ((node-info (line->node-info (car (read-block in))))
165            (admins (read-block in))
166            (guests (read-block in)))
167       ;; According to the docs, there's more info after GUESTS but I can't
168       ;; seem to get this, so let's just read out just to be sure (for now)
169       (discard-output in)
170       `(,@node-info (admin-users . ,admins) (guest-users . ,guests))))))
171
172(define (get-cache-usage base-uri node)
173  (string->number
174   (exec 'get-cache-usage (node-uri base-uri node "cacheusage") #f read-line)))
175
176(define (optimize-node base-uri node)
177  (exec 'optimize-node (node-uri base-uri node "optimize") #f discard-output))
178
179(define (sync-node base-uri node)
180  (exec 'sync-node (node-uri base-uri node "sync") #f discard-output))
181
182(define (list-documents base-uri node #!key max prev)
183  (exec 'list-documents
184        (node-uri base-uri node "list" query: `((max . ,max) (prev . ,prev)))
185        #f
186        (lambda (in)
187          (map (lambda (line)
188                 (map cons
189                      `(@id @uri @digest @cdate @mdate @adate @title @author
190                            @type @lang @genre @size @weight @misc)
191                      (string-split line "\t" #t)))
192               (read-lines in)))))
193
194(define (put-document base-uri node contents attribs)
195  (exec
196   'put-document
197   (make-request uri: (node-uri base-uri node "put_doc")
198                 method: 'POST major: 1 minor: 0
199                 headers: (headers '((content-type text/x-estraier-draft))))
200   (call-with-output-string ; use string because it wants content-length
201     ;; Can't write @digest because that would invalidate the document
202     (lambda (out) (write-draft out (alist-delete '@digest attribs) contents)))
203   discard-output))
204
205(define (delete-document base-uri node #!key id uri)
206  (exec 'delete-document
207        (node-uri base-uri node "out_doc"
208                  query: (id/uri->alist 'delete-document id uri))
209        #f discard-output))
210
211(define (document-uri->id base-uri node uri)
212  (exec 'document-uri->id
213        (node-uri base-uri node "uri_to_id"
214                  query: `((uri . ,uri))) #f read-line))
215
216(define (get-document base-uri node #!key id uri)
217  (apply values
218         (exec
219          'get-document
220          (node-uri base-uri node "get_doc"
221                    query: (id/uri->alist 'get-document id uri))
222          #f (lambda (in)
223               (call-with-values (lambda () (read-draft in)) list)))))
224
225;; This requires the new attributes plus all the old attribs, it
226;; simply replaces the document's attributes.  This also means it
227;; requires both @uri and @id!  Anything not present is reset or
228;; removed.  It's identical to put-document, except for the doc body.
229(define (update-attributes base-uri node attribs)
230  (exec
231   'update-attributes
232   (make-request uri: (node-uri base-uri node "edit_doc")
233                 method: 'POST major: 1 minor: 0
234                 headers: (headers '((content-type text/x-estraier-draft))))
235   (call-with-output-string ; use string because it wants content-length
236     ;; Can't write @digest because that would invalidate the document
237     (lambda (out) (write-attributes out (alist-delete '@digest attribs))))
238   discard-output))
239
240(define (document-attribute base-uri node attrib #!key id uri)
241  (exec 'document-attribute
242        (node-uri base-uri node "get_doc_attr"
243                  query: (cons `(attr . ,attrib)
244                               (id/uri->alist 'document-attribute id uri)))
245        #f read-line))
246
247(define (document-keywords base-uri node #!key id uri)
248  (exec 'document-keywords
249        (node-uri base-uri node "etch_doc"
250                  query: (id/uri->alist 'document-keywords id uri))
251        #f
252        (lambda (in)
253          (let loop ((line (read-line in))
254                     (keywords (list)))
255            (if (eof-object? line)
256                (reverse! keywords) ;; preserve keyword document order
257                (let ((kwd/score (string-split line "\t" #t)))
258                  (loop (read-line in)
259                        (cons (cons (first kwd/score)
260                                    (string->number (second kwd/score)))
261                              keywords))))))))
262
263;; Attrs are ANDed together.  All attribute phrases must match
264(define (find-documents base-uri node #!key phrase (attr-phrases '())
265                        order max options auxiliary distinct depth
266                        wwidth hwidth awidth skip mask)
267  (when (> (length attr-phrases) 10)
268    (signal
269     (estraier-exn 'find-documents
270                   (conc "You can't provide more than 10 attribute phrases. "
271                         "This is a limitation of the estraier API. Sorry!")
272                   'args)))
273  ;; Normalise attr-phrases list to attr, attr1, ... attr9
274  (let ((attrs (map (lambda (a i)
275                      (if (zero? i)
276                          (cons 'attr a)
277                          (cons (sprintf "attr~A" i) a)))
278                    attr-phrases
279                    (iota 10))))
280   (apply
281    values
282    (exec 'find-documents
283          (node-uri base-uri node "search"
284                    query: `((phrase . ,phrase) (order . ,order)
285                             (max . ,max)       (options . ,options)
286                             (depth . ,depth)   (wwidth . ,wwidth)
287                             (hwidth . ,hwidth) (awidth . ,awidth)
288                             (skip . ,skip)     (mask . ,mask)
289                             (auxiliary . ,auxiliary)
290                             (distinct . ,distinct)
291                             ,@attrs))
292          #f
293          (lambda (in)
294            (let* ((delimiter (read-line in))
295                   (meta
296                    (let next-line ((line (read-line in))
297                                    (metadata (list)))
298                      ;; There's a pointless blank line at the end... skip over it
299                      (if (string-null? line)
300                          (next-line (read-line in) metadata)
301                          (if (string-prefix? delimiter line)
302                              (reverse! metadata) ; done, continue to snippets
303                              (let ((data (string-split line "\t" #t)))
304                                (next-line (read-line in)
305                                           (cons (cons (string->symbol (car data))
306                                                       (cdr data))
307                                                 metadata)))))))
308                   (documents
309                    (let next-document ((docs (list)))
310                      (let ((attribs (read-attributes in)))
311                        (let next-line ((matches (list))
312                                        (line  (read-line in)))
313                          (cond
314                           ;; We're not relying on :END here since it would
315                           ;; complicate matters with zero search results.
316                           ((eof-object? line)
317                            (reverse! docs))
318                           ((string-prefix? delimiter line)
319                            (next-document (cons (cons (reverse! matches) attribs)
320                                                 docs)))
321                           ;; Discard pointless empty lines.. there's at least
322                           ;; one at the end of each block.
323                           ((string-null? line)
324                            (next-line matches (read-line in)))
325                           (else
326                            (let* ((idx (string-index line #\tab))
327                                   (highlight (and idx (string-take line idx)))
328                                   (match (if idx
329                                              (string-drop line (add1 idx))
330                                              line)))
331                              (next-line (cons (cons highlight match) matches)
332                                         (read-line in))))))))))
333              (list documents meta)))))))
334
335(define (_set-user loc base-uri node name mode)
336  (exec loc (node-uri base-uri node "_set_user"
337                      query: `((name . ,name) (mode . ,mode)))
338        #f read-lines))
339
340(define (unregister-user base-uri node name)
341  (_set-user 'unregister-user base-uri node name 0))
342
343(define (register-admin-user base-uri node name)
344  (_set-user 'register-admin-user base-uri node name 1))
345
346(define (register-guest-user base-uri node name)
347  (_set-user 'register-guest-user base-uri node name 2))
348
349;; TODO: _set_link
350
351;;;; Master API
352
353(define (master-uri base-uri action . args)
354  (let ((uri (if (uri-reference? base-uri)
355                 (apply update-uri base-uri args)
356                 (apply update-uri (uri-reference base-uri) args))))
357    (update-uri (uri-relative-to (uri-reference "./master") uri)
358                query: (alist-update! 'action action (uri-query uri)))))
359
360(define (shutdown-master base-uri)
361  (exec 'shutdown-master (master-uri base-uri "shutdown") #f discard-output))
362
363(define (sync-master base-uri)
364  (exec 'sync-master (master-uri base-uri "sync") #f discard-output))
365
366(define (backup-master base-uri)
367  (exec 'backup-master (master-uri base-uri "backup") #f discard-output))
368
369(define (rotate-log base-uri)
370  (exec 'rotate-log (master-uri base-uri "logrtt") #f discard-output))
371
372(define (list-nodes base-uri)
373  (map line->node-info
374       (exec 'list-nodes (master-uri base-uri "nodelist") #f read-lines)))
375
376(define (add-node base-uri node-name #!optional node-label)
377  (exec 'add-node
378        (master-uri base-uri "nodeadd"
379                    query: `((name . ,node-name) (label . ,node-label)))
380        #f discard-output))
381
382(define (delete-node base-uri node-name)
383  (exec 'delete-node
384        (master-uri base-uri "nodedel" query: `((name . ,node-name)))
385        #f discard-output))
386
387(define (clear-node base-uri node-name)
388  (exec 'clear-node
389        (master-uri base-uri "nodeclr" query: `((name . ,node-name)))
390        #f discard-output))
391
392(define (list-users base-uri)
393  (exec 'list-users
394        (master-uri base-uri "userlist")
395        #f
396        (lambda (in)
397          (let loop ((line (read-line in))
398                     (lines (list)))
399            (if (eof-object? line)
400                (reverse! lines)
401                (loop (read-line in)
402                      (cons (string-split line "\t" #t) lines)))))))
403
404(define (add-user base-uri username password
405                  #!key flags fullname description)
406  (exec 'add-user
407        (make-request uri: (master-uri base-uri "useradd")
408                      method: 'POST major: 1 minor: 0)
409        `((name . ,username) (passwd . ,password)
410          (flags . ,flags) (fname . ,fullname) (misc . ,description))
411        discard-output))
412
413(define (delete-user base-uri username)
414  (exec 'delete-user
415        (master-uri base-uri "userdel" query: `((name . ,username)))
416        #f discard-output))
417
418)
Note: See TracBrowser for help on using the repository browser.