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

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

Add some more tests

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