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

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

Split out 'draft' and attribute reading/writing procedures

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;; 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   clean-attributes 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;; If control commands or the @digest attribute are sent back when
137;; updating a document, the node will silently ignore the document...
138(define (clean-attributes attributes)
139  (filter (lambda (attrib)
140            (and (not (string-prefix? "#" (->string (car attrib))))
141                 (not (eq? (car attrib) '@digest))))
142          attributes))
143
144(define (write-attributes outport attributes)
145  (for-each (lambda (attrib)
146              (fprintf outport "~A=~A\r\n" (car attrib) (cdr attrib)))
147            attributes))
148
149;; Write out a document in "draft" format to the specified output port.
150(define (write-draft outport attributes contents)
151  (write-attributes outport attributes)
152  (fprintf outport "\r\n")
153  ;; What if there's a newline in the text?
154  (for-each (lambda (line) (fprintf outport "~A\r\n" line)) contents))
155
156(define (read-attributes inport)
157  (map split-attrib-line
158       ;; Remove control commands like %VECTOR for now
159       (filter (lambda (line)
160                 (string-index line #\=))
161               (read-block inport))))
162
163;; Read a document in "draft" format from the specified input port.
164(define (read-draft inport)
165  (let ((metadata (read-attributes inport))
166        (document (read-lines inport)))
167    (values document metadata)))
168
169(define (put-document node contents attribs)
170  (exec
171   (make-request uri: (node-uri node "put_doc")
172                 method: 'POST major: 1 minor: 0
173                 headers: (headers '((content-type text/x-estraier-draft))))
174   (call-with-output-string ; use string because it wants content-length
175     (lambda (out) (write-draft out (clean-attributes attribs) contents)))
176   discard-output))
177
178(define (delete-document node #!key id uri)
179  (exec (node-uri node "out_doc" query: (id/uri->alist id uri))
180        #f discard-output))
181
182(define (document-uri->id node uri)
183  (exec (node-uri node "uri_to_id" query: `((uri . ,uri))) #f read-line))
184
185(define (get-document node #!key id uri)
186  (apply values
187         (exec
188          (node-uri node "get_doc" query: (id/uri->alist id uri))
189          #f (lambda (in)
190               (call-with-values (lambda () (read-draft in)) list)))))
191
192;; This requires the new attributes plus all the old attribs, it
193;; simply replaces the document's attributes.  This also means it
194;; requires both @uri and @id!  Anything not present is reset or
195;; removed.  It's identical to put-document, except for the doc body.
196(define (update-attributes node attribs)
197  (exec
198   (make-request uri: (node-uri node "edit_doc")
199                 method: 'POST major: 1 minor: 0
200                 headers: (headers '((content-type text/x-estraier-draft))))
201   (call-with-output-string ; use string because it wants content-length
202     (lambda (out) (write-attributes out (clean-attributes attribs))))
203   discard-output))
204
205(define (document-attribute node attrib #!key id uri)
206  (exec (node-uri node "get_doc_attr" query: (cons `(attr . ,(->string attrib))
207                                                   (id/uri->alist id uri)))
208        #f read-line))
209
210(define (document-keywords node #!key id uri)
211  (exec (node-uri node "etch_doc" query: (id/uri->alist id uri))
212        #f
213        (lambda (in)
214          (let loop ((line (read-line in))
215                     (keywords (list)))
216            (if (eof-object? line)
217                (reverse! keywords) ;; preserve keyword document order
218                (let ((kwd/score (string-split line "\t" #t)))
219                  (loop (read-line in)
220                        (cons (cons (first kwd/score)
221                                    (string->number (second kwd/score)))
222                              keywords))))))))
223
224(define (find-documents node #!key phrase attr order max options auxiliary
225                        distinct depth wwidth hwidth awidth skip mask)
226  (apply
227   values
228   (exec (node-uri node "search"
229                   query: `((phrase . ,phrase)
230                            (attr . ,attr)
231                            (order . ,order)
232                            (max . ,(and max (->string max)))
233                            (options . ,(and options (->string options)))
234                            (auxiliary . ,(and auxiliary (->string auxiliary)))
235                            (distinct . ,distinct)
236                            (depth . ,(and depth (->string depth)))
237                            (wwidth . ,(and wwidth (->string wwidth)))
238                            (hwidth . ,(and hwidth (->string hwidth)))
239                            (awidth . ,(and awidth (->string awidth)))
240                            (skip . ,(and skip (->string skip)))
241                            (mask . ,(and mask (->string mask)))))
242         #f
243         (lambda (in)
244           (let* ((delimiter (read-line in))
245                  (meta
246                   (let next-line ((line (read-line in))
247                                   (metadata (list)))
248                     ;; There's a pointless blank line at the end... skip over it
249                     (if (string-null? line)
250                         (next-line (read-line in) metadata)
251                         (if (string-prefix? delimiter line)
252                             (reverse! metadata) ; done, continue to snippets
253                             (let ((data (string-split line "\t" #t)))
254                               (next-line (read-line in)
255                                          (cons (cons (string->symbol (car data))
256                                                      (cdr data))
257                                                metadata)))))))
258                  (documents
259                   (let next-document ((docs (list)))
260                     (let ((attribs (read-attributes in)))
261                       (let next-line ((matches (list))
262                                       (line  (read-line in)))
263                         (cond
264                          ;; We're not relying on :END here since it would
265                          ;; complicate matters with zero search results.
266                          ((eof-object? line)
267                           (reverse! docs))
268                          ((string-prefix? delimiter line)
269                           (next-document (cons (cons (reverse! matches) attribs)
270                                                docs)))
271                          ;; Discard pointless empty lines.. there's at least
272                          ;; one at the end of each block.
273                          ((string-null? line)
274                           (next-line matches (read-line in)))
275                          (else
276                           (let* ((idx (string-index line #\tab))
277                                  (highlight (and idx (string-take line idx)))
278                                  (match (if idx
279                                             (string-drop line (add1 idx))
280                                             line)))
281                             (next-line (cons (cons highlight match) matches)
282                                        (read-line in))))))))))
283             (list documents meta))))))
284
285(define (_set-user node name mode)
286  (exec (node-uri node "_set_user" query: `((name . ,name)
287                                            (mode . ,(->string mode))))
288        #f read-lines))
289
290(define (unregister-user node name)
291  (_set-user node name 0))
292
293(define (register-admin-user node name)
294  (_set-user node name 1))
295
296(define (register-guest-user node name)
297  (_set-user node name 2))
298
299;; TODO: _set_link
300
301;;;; Master API
302
303;; TODO: Maybe change the name so this is not all prefixed "master-"?
304;; The node procedures are not prefixed "node-" either.
305(define (master-uri master action . args)
306  (let ((uri (if (uri-reference? master)
307                 (apply update-uri master args)
308                 (apply update-uri (uri-reference master) args))))
309    (update-uri uri query: (alist-update! 'action action (uri-query uri)))))
310
311(define (master-shutdown master)
312  (exec (master-uri master "shutdown") #f discard-output))
313
314(define (master-sync master)
315  (exec (master-uri master "sync") #f discard-output))
316
317(define (master-backup master)
318  (exec (master-uri master "backup") #f discard-output))
319
320(define (master-rotate-log master)
321  (exec (master-uri master "logrtt") #f discard-output))
322
323(define (master-nodes master)
324  (map (lambda (line)
325         (string-split line "\t" #t))
326       (exec (master-uri master "nodelist") #f read-lines)))
327
328(define (master-add-node master node-name #!optional node-label)
329  (exec (master-uri master "nodeadd"
330                    query: `((name . ,node-name) (label . ,node-label)))
331        #f discard-output))
332
333(define (master-delete-node master node-name)
334  (exec (master-uri master "nodedel" query: `((name . ,node-name)))
335        #f discard-output))
336
337(define (master-clear-node master node-name)
338  (exec (master-uri master "nodeclr" query: `((name . ,node-name)))
339        #f discard-output))
340
341(define (master-users master)
342  (exec (master-uri master "userlist")
343        #f
344        (lambda (in)
345          (let loop ((line (read-line in))
346                     (lines (list)))
347            (if (eof-object? line)
348                (reverse! lines)
349                (loop (read-line in)
350                      (cons (string-split line "\t" #t) lines)))))))
351
352(define (master-add-user master username password
353                         #!key flags fullname description)
354  (exec (make-request uri: (master-uri master "useradd")
355                      method: 'POST major: 1 minor: 0)
356        `((name . ,username) (passwd . ,password)
357          (flags . ,flags) (fname . ,fullname) (misc . ,description))
358        discard-output))
359
360(define (master-delete-user master username)
361  (exec (master-uri master "userdel" query: `((name . ,username)))
362        #f discard-output))
363
364)
Note: See TracBrowser for help on using the repository browser.