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

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

Add some sanity to attribute searching

File size: 15.4 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;; Attrs are ANDed together.  All attribute phrases must match
219(define (find-documents node #!key phrase (attr-phrases '()) order max options
220                        auxiliary distinct depth wwidth hwidth awidth skip mask)
221  (when (> (length attr-phrases) 10)
222    (error (string-append "You can't provide more than 10 attribute phrases. "
223                          "This is a limitation of the estraier API. Sorry!")))
224  ;; Normalise attr-phrases list to attr, attr1, ... attr9
225  (let ((attrs (map (lambda (a i)
226                      (if (zero? i)
227                          (cons 'attr a)
228                          (cons (sprintf "attr~A" i) a)))
229                    attr-phrases
230                    (iota 10))))
231   (apply
232    values
233    (exec (node-uri node "search"
234                    query: `((phrase . ,phrase)
235                             (order . ,order)
236                             (max . ,(and max (->string max)))
237                             (options . ,(and options (->string options)))
238                             (auxiliary . ,(and auxiliary (->string auxiliary)))
239                             (distinct . ,distinct)
240                             (depth . ,(and depth (->string depth)))
241                             (wwidth . ,(and wwidth (->string wwidth)))
242                             (hwidth . ,(and hwidth (->string hwidth)))
243                             (awidth . ,(and awidth (->string awidth)))
244                             (skip . ,(and skip (->string skip)))
245                             (mask . ,(and mask (->string mask)))
246                             ,@attrs))
247          #f
248          (lambda (in)
249            (let* ((delimiter (read-line in))
250                   (meta
251                    (let next-line ((line (read-line in))
252                                    (metadata (list)))
253                      ;; There's a pointless blank line at the end... skip over it
254                      (if (string-null? line)
255                          (next-line (read-line in) metadata)
256                          (if (string-prefix? delimiter line)
257                              (reverse! metadata) ; done, continue to snippets
258                              (let ((data (string-split line "\t" #t)))
259                                (next-line (read-line in)
260                                           (cons (cons (string->symbol (car data))
261                                                       (cdr data))
262                                                 metadata)))))))
263                   (documents
264                    (let next-document ((docs (list)))
265                      (let ((attribs (read-attributes in)))
266                        (let next-line ((matches (list))
267                                        (line  (read-line in)))
268                          (cond
269                           ;; We're not relying on :END here since it would
270                           ;; complicate matters with zero search results.
271                           ((eof-object? line)
272                            (reverse! docs))
273                           ((string-prefix? delimiter line)
274                            (next-document (cons (cons (reverse! matches) attribs)
275                                                 docs)))
276                           ;; Discard pointless empty lines.. there's at least
277                           ;; one at the end of each block.
278                           ((string-null? line)
279                            (next-line matches (read-line in)))
280                           (else
281                            (let* ((idx (string-index line #\tab))
282                                   (highlight (and idx (string-take line idx)))
283                                   (match (if idx
284                                              (string-drop line (add1 idx))
285                                              line)))
286                              (next-line (cons (cons highlight match) matches)
287                                         (read-line in))))))))))
288              (list documents meta)))))))
289
290(define (_set-user node name mode)
291  (exec (node-uri node "_set_user" query: `((name . ,name)
292                                            (mode . ,(->string mode))))
293        #f read-lines))
294
295(define (unregister-user node name)
296  (_set-user node name 0))
297
298(define (register-admin-user node name)
299  (_set-user node name 1))
300
301(define (register-guest-user node name)
302  (_set-user node name 2))
303
304;; TODO: _set_link
305
306;;;; Master API
307
308;; TODO: Maybe change the name so this is not all prefixed "master-"?
309;; The node procedures are not prefixed "node-" either.
310(define (master-uri master action . args)
311  (let ((uri (if (uri-reference? master)
312                 (apply update-uri master args)
313                 (apply update-uri (uri-reference master) args))))
314    (update-uri uri query: (alist-update! 'action action (uri-query uri)))))
315
316(define (master-shutdown master)
317  (exec (master-uri master "shutdown") #f discard-output))
318
319(define (master-sync master)
320  (exec (master-uri master "sync") #f discard-output))
321
322(define (master-backup master)
323  (exec (master-uri master "backup") #f discard-output))
324
325(define (master-rotate-log master)
326  (exec (master-uri master "logrtt") #f discard-output))
327
328(define (master-nodes master)
329  (map (lambda (line)
330         (string-split line "\t" #t))
331       (exec (master-uri master "nodelist") #f read-lines)))
332
333(define (master-add-node master node-name #!optional node-label)
334  (exec (master-uri master "nodeadd"
335                    query: `((name . ,node-name) (label . ,node-label)))
336        #f discard-output))
337
338(define (master-delete-node master node-name)
339  (exec (master-uri master "nodedel" query: `((name . ,node-name)))
340        #f discard-output))
341
342(define (master-clear-node master node-name)
343  (exec (master-uri master "nodeclr" query: `((name . ,node-name)))
344        #f discard-output))
345
346(define (master-users master)
347  (exec (master-uri master "userlist")
348        #f
349        (lambda (in)
350          (let loop ((line (read-line in))
351                     (lines (list)))
352            (if (eof-object? line)
353                (reverse! lines)
354                (loop (read-line in)
355                      (cons (string-split line "\t" #t) lines)))))))
356
357(define (master-add-user master username password
358                         #!key flags fullname description)
359  (exec (make-request uri: (master-uri master "useradd")
360                      method: 'POST major: 1 minor: 0)
361        `((name . ,username) (passwd . ,password)
362          (flags . ,flags) (fname . ,fullname) (misc . ,description))
363        discard-output))
364
365(define (master-delete-user master username)
366  (exec (master-uri master "userdel" query: `((name . ,username)))
367        #f discard-output))
368
369)
Note: See TracBrowser for help on using the repository browser.