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

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

Remove some pointless tedious ugly code for converting attribute values to strings, and rely on the new uri-common 0.9 to do that automatically

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