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

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

We don't really need clean-attributes, we only need to remove @digest

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