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

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

Normalize exported names a bit

File size: 14.6 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;; TODO: Perhaps split URIs into "base uri" and "node name".
38
39(module estraier-client
40  (get-node-info node-cache-usage optimize-node sync-node document-uri->id
41   list-documents put-document delete-document get-document
42   update-attributes document-attribute document-keywords find-documents
43   unregister-user register-admin-user register-guest-user
44   
45   ;; these could be useful on their own, so export them too
46   read-attributes read-draft write-attributes write-draft
47
48   shutdown-master sync-master backup-master rotate-log
49   list-nodes add-node delete-node clear-node list-users add-user delete-user)
50
51(import chicken scheme)
52(use data-structures extras ports srfi-1 srfi-13 http-client uri-common intarweb)
53
54;; Exhaust input port with web-server's output (yes, confusing) and return void
55(define (discard-output in)
56  (let loop ((line (read-line in)))
57    (if (eof-object? line) (void) (loop (read-line in)))))
58
59(define (exec uri writer reader)
60  ;; Estraier doesn't understand the preferred ";" separator
61  (parameterize ((form-urlencoded-separator "&"))
62    (call-with-input-request uri writer reader)))
63
64;; Read one block of data. The Hyper Estraier API sends data out in blocks
65;; separated by newlines.  The lines in the block are returned as a list
66(define (read-block inport)
67  (let loop ((result (list))
68             (line (read-line inport)))
69    (if (or (eof-object? line) (string-null? line))
70        (reverse! result)
71        (loop (cons line result) (read-line inport)))))
72
73(define (split-attrib-line attrib-line)
74  (let ((idx (string-index attrib-line #\=)))
75    (cons (string->symbol (string-take attrib-line idx))
76          (string-drop attrib-line (add1 idx)))))
77
78;; Helper procedure for checking that id xor uri is supplied
79(define (id/uri->alist id uri)
80  (cond
81   ((and id (not uri)) `((id . ,id)))
82   ((and uri (not id)) `((uri . ,uri)))
83   (else (error "You must supply either an id or a uri"))))
84
85;;;; Node API
86
87(define (node-uri node action . args)
88  (let ((uri (if (uri-reference? node)
89                 (apply update-uri node args)
90                 (apply update-uri (uri-reference node) args))))
91    (update-uri uri path: (append (uri-path uri) (list action)))))
92
93(define (get-node-info node)
94  (exec
95   (node-uri node "inform")
96   #f
97   (lambda (in)
98     (let* ((db-info (string-split (car (read-block in)) "\t" #t))
99            (admins (read-block in))
100            (guests (read-block in)))
101       ;; According to the docs, there's more info after GUESTS but I can't
102       ;; seem to get this, so let's just read out just to be sure (for now)
103       (discard-output in)
104       `((name . ,(first db-info))
105         (label . ,(second db-info))
106         (document-count . ,(string->number (third db-info)))
107         (word-count . ,(string->number (fourth db-info)))
108         (size . ,(string->number (fifth db-info)))
109         (admin-users . ,admins)
110         (guest-users . ,guests))))))
111
112(define (node-cache-usage node)
113  (string->number (exec (node-uri node "cacheusage") #f read-line)))
114
115(define (optimize-node node)
116  (exec (node-uri node "optimize") #f discard-output))
117
118(define (sync-node node)
119  (exec (node-uri node "sync") #f discard-output))
120
121(define (list-documents node #!key max prev)
122  (exec (node-uri node "list" query: `((max . ,max) (prev . ,prev)))
123        #f
124        (lambda (in)
125          (map (lambda (line)
126                 (map cons
127                      `(@id @uri @digest @cdate @mdate @adate @title @author
128                            @type @lang @genre @size @weight @misc)
129                      (string-split line "\t" #t)))
130               (read-lines in)))))
131
132(define (write-attributes outport attributes)
133  (for-each (lambda (attrib)
134              (fprintf outport "~A=~A\r\n" (car attrib) (cdr attrib)))
135            attributes))
136
137;; Write out a document in "draft" format to the specified output port.
138(define (write-draft outport attributes contents)
139  (write-attributes outport attributes)
140  (fprintf outport "\r\n")
141  ;; What if there's a newline in the text?
142  (for-each (lambda (line) (fprintf outport "~A\r\n" line)) contents))
143
144(define (read-attributes inport)
145  (map split-attrib-line
146       ;; Remove control commands like %VECTOR for now
147       (filter (lambda (line)
148                 (string-index line #\=))
149               (read-block inport))))
150
151;; Read a document in "draft" format from the specified input port.
152(define (read-draft inport)
153  (let* ((metadata (read-attributes inport))
154         (document (read-lines inport)))
155    (values document metadata)))
156
157(define (put-document node contents attribs)
158  (exec
159   (make-request uri: (node-uri node "put_doc")
160                 method: 'POST major: 1 minor: 0
161                 headers: (headers '((content-type text/x-estraier-draft))))
162   (call-with-output-string ; use string because it wants content-length
163     ;; Can't write @digest because that would invalidate the document
164     (lambda (out) (write-draft out (alist-delete '@digest attribs) contents)))
165   discard-output))
166
167(define (delete-document node #!key id uri)
168  (exec (node-uri node "out_doc" query: (id/uri->alist id uri))
169        #f discard-output))
170
171(define (document-uri->id node uri)
172  (exec (node-uri node "uri_to_id" query: `((uri . ,uri))) #f read-line))
173
174(define (get-document node #!key id uri)
175  (apply values
176         (exec
177          (node-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 node attribs)
186  (exec
187   (make-request uri: (node-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 node attrib #!key id uri)
196  (exec (node-uri node "get_doc_attr" query: (cons `(attr . ,attrib)
197                                                   (id/uri->alist id uri)))
198        #f read-line))
199
200(define (document-keywords node #!key id uri)
201  (exec (node-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 node #!key phrase (attr-phrases '()) order max options
216                        auxiliary distinct depth wwidth hwidth awidth skip mask)
217  (when (> (length attr-phrases) 10)
218    (error (string-append "You can't provide more than 10 attribute phrases. "
219                          "This is a limitation of the estraier API. Sorry!")))
220  ;; Normalise attr-phrases list to attr, attr1, ... attr9
221  (let ((attrs (map (lambda (a i)
222                      (if (zero? i)
223                          (cons 'attr a)
224                          (cons (sprintf "attr~A" i) a)))
225                    attr-phrases
226                    (iota 10))))
227   (apply
228    values
229    (exec (node-uri node "search"
230                    query: `((phrase . ,phrase) (order . ,order)
231                             (max . ,max)       (options . ,options)
232                             (depth . ,depth)   (wwidth . ,wwidth)
233                             (hwidth . ,hwidth) (awidth . ,awidth)
234                             (skip . ,skip)     (mask . ,mask)
235                             (auxiliary . ,auxiliary)
236                             (distinct . ,distinct)
237                             ,@attrs))
238          #f
239          (lambda (in)
240            (let* ((delimiter (read-line in))
241                   (meta
242                    (let next-line ((line (read-line in))
243                                    (metadata (list)))
244                      ;; There's a pointless blank line at the end... skip over it
245                      (if (string-null? line)
246                          (next-line (read-line in) metadata)
247                          (if (string-prefix? delimiter line)
248                              (reverse! metadata) ; done, continue to snippets
249                              (let ((data (string-split line "\t" #t)))
250                                (next-line (read-line in)
251                                           (cons (cons (string->symbol (car data))
252                                                       (cdr data))
253                                                 metadata)))))))
254                   (documents
255                    (let next-document ((docs (list)))
256                      (let ((attribs (read-attributes in)))
257                        (let next-line ((matches (list))
258                                        (line  (read-line in)))
259                          (cond
260                           ;; We're not relying on :END here since it would
261                           ;; complicate matters with zero search results.
262                           ((eof-object? line)
263                            (reverse! docs))
264                           ((string-prefix? delimiter line)
265                            (next-document (cons (cons (reverse! matches) attribs)
266                                                 docs)))
267                           ;; Discard pointless empty lines.. there's at least
268                           ;; one at the end of each block.
269                           ((string-null? line)
270                            (next-line matches (read-line in)))
271                           (else
272                            (let* ((idx (string-index line #\tab))
273                                   (highlight (and idx (string-take line idx)))
274                                   (match (if idx
275                                              (string-drop line (add1 idx))
276                                              line)))
277                              (next-line (cons (cons highlight match) matches)
278                                         (read-line in))))))))))
279              (list documents meta)))))))
280
281(define (_set-user node name mode)
282  (exec (node-uri node "_set_user" query: `((name . ,name) (mode . ,mode)))
283        #f read-lines))
284
285(define (unregister-user node name)
286  (_set-user node name 0))
287
288(define (register-admin-user node name)
289  (_set-user node name 1))
290
291(define (register-guest-user node name)
292  (_set-user node name 2))
293
294;; TODO: _set_link
295
296;;;; Master API
297
298(define (master-uri master action . args)
299  (let ((uri (if (uri-reference? master)
300                 (apply update-uri master args)
301                 (apply update-uri (uri-reference master) args))))
302    (update-uri uri query: (alist-update! 'action action (uri-query uri)))))
303
304(define (shutdown-master master)
305  (exec (master-uri master "shutdown") #f discard-output))
306
307(define (sync-master master)
308  (exec (master-uri master "sync") #f discard-output))
309
310(define (backup-master master)
311  (exec (master-uri master "backup") #f discard-output))
312
313(define (rotate-log master)
314  (exec (master-uri master "logrtt") #f discard-output))
315
316(define (list-nodes master)
317  (map (lambda (line)
318         (string-split line "\t" #t))
319       (exec (master-uri master "nodelist") #f read-lines)))
320
321(define (add-node master node-name #!optional node-label)
322  (exec (master-uri master "nodeadd"
323                    query: `((name . ,node-name) (label . ,node-label)))
324        #f discard-output))
325
326(define (delete-node master node-name)
327  (exec (master-uri master "nodedel" query: `((name . ,node-name)))
328        #f discard-output))
329
330(define (clear-node master node-name)
331  (exec (master-uri master "nodeclr" query: `((name . ,node-name)))
332        #f discard-output))
333
334(define (list-users master)
335  (exec (master-uri master "userlist")
336        #f
337        (lambda (in)
338          (let loop ((line (read-line in))
339                     (lines (list)))
340            (if (eof-object? line)
341                (reverse! lines)
342                (loop (read-line in)
343                      (cons (string-split line "\t" #t) lines)))))))
344
345(define (add-user master username password
346                         #!key flags fullname description)
347  (exec (make-request uri: (master-uri master "useradd")
348                      method: 'POST major: 1 minor: 0)
349        `((name . ,username) (passwd . ,password)
350          (flags . ,flags) (fname . ,fullname) (misc . ,description))
351        discard-output))
352
353(define (delete-user master username)
354  (exec (master-uri master "userdel" query: `((name . ,username)))
355        #f discard-output))
356
357)
Note: See TracBrowser for help on using the repository browser.