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

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

Don't gratuitously convert IDs to numbers. It just causes confusion (and who is to say that ids are guaranteed to always be numeric?)

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