source: project/release/4/couchdb/couchdb.scm @ 16098

Last change on this file since 16098 was 16092, checked in by Moritz Heidkamp, 11 years ago

Initial commit of the couchdb client library

File size: 7.4 KB
Line 
1;; Apache CouchDB client library
2;;
3;; Copyright (C) 2009 Moritz Heidkamp
4;;
5;; This program is free software; you can redistribute it and/or
6;; modify it under the terms of the GNU General Public License as
7;; published by the Free Software Foundation; either version 3 of the
8;; License, or (at your option) any later version.
9;;
10;; This program is distributed in the hope that it will be useful, but
11;; WITHOUT ANY WARRANTY; without even the implied warranty of
12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13;; General Public License for more details.
14;;
15;; You can find a copy of the GNU General Public License at
16;; http://www.gnu.org/licenses/
17
18(module couchdb 
19  (server database last-error 
20
21   make-document document-id document-rev document-body update-document
22   document-attribute json-ref
23
24   get-server-info get-document save-document delete-document 
25   create-database delete-database get-database-info)
26
27
28(import chicken scheme)
29
30(require-library intarweb)
31(import (rename intarweb (headers alist->headers)))
32
33(use http-client json uri-common extras ports srfi-1 data-structures defstruct srfi-69)
34
35;; Default server URI and database name
36(define server (make-parameter (uri-reference "http://localhost:5984/")))
37(define database (make-parameter #f))
38
39;; Whenever errors occur, a descriptive message can be accessed through last-error
40(define last-error (make-parameter #f))
41
42;; Internal mapping for couchdb error keys
43(define errors '(("illegal_database_name" . "Illegal database name")))
44
45;; Convenience method for setting and signalling an error (i.e. returning #f)
46(define (last-error! e) 
47  (last-error e) #f)
48
49;; Signals a couchdb exception
50(define (couchdb-error location message)
51  (signal (make-composite-condition 
52           (make-property-condition 'exn 'message message 'location location)
53           (make-property-condition 'couchdb))))
54
55;; Retrieves a field from a JSON object vector or hash-table
56(define (json-ref name object) 
57  (let* ([object (if (vector? object) (vector->list object) (hash-table->alist object))]
58         [pair (assoc (->string name) object)])
59    (and pair (cdr pair))))
60
61;; Parses a condition property as JSON
62(define (condition-property->json e type property)
63  (with-input-from-string (condition-property e type property) json-read))
64
65;; Convenience function for accessing condition properties
66(define (condition-property e type property)
67  ((condition-property-accessor type property) e))
68
69;; Appends path to the path of uri and returns the resulting uri
70(define (uri-path-append uri . path)
71  (update-uri uri path: (append (uri-path uri) (filter string? path))))
72
73;; Syntax for handling http-client client-errors by HTTP status code
74(define-syntax handling-client-errors
75  (syntax-rules ()
76    ((_ exn statement handler1 handler2 ...)
77     (condition-case statement
78                     (exn (client-error)
79                          (case (response-code (condition-property exn 'client-error 'response))
80                            handler1 handler2 ...
81                            (else (abort exn))))))))
82
83;; Returns only the body of a http response since that is all we care about most of the time
84(define-syntax returning-body
85  (syntax-rules ()
86    ((_ e) (receive (b u r) e b))))
87
88
89(defstruct document id rev (body '#()))
90
91(define (avector->document avector)
92  (let* ([body (alist->hash-table 
93                (map (lambda (p) (cons (string->symbol (car p))
94                                       (if (vector? (cdr p))
95                                           (avector->hash-table (cdr p)) (cdr p))))
96                     (vector->list avector)))]
97         [id (hash-table-ref body '_id)]
98         [rev (hash-table-ref body '_rev)])
99
100    (hash-table-delete! body '_id)
101    (hash-table-delete! body '_rev)
102
103    (make-document id:   id
104                   rev:  rev
105                   body: body)))
106
107(define (avector->hash-table av)
108  (alist->hash-table
109   (map (lambda (p) (cons (string->symbol (car p))
110                          (if (vector? (cdr p))
111                              (avector->hash-table (cdr p)) (cdr p)))) (vector->list av))))
112
113(define (document-attribute doc name)
114  (hash-table-ref (document-body doc) name))
115
116;; General request method with some couchdb specific error handling
117(define (send-request request #!optional (input #f))
118  (condition-case (returning-body (with-input-from-request request input json-read))
119                  (exn (server-error)
120                       (let* ([body (condition-property->json exn 'server-error 'body)]
121                              [error-key (and body (json-ref 'reason body))]
122                              [error (assoc error-key errors)])
123                         (if error
124                             (last-error! (cdr error))
125                             (signal exn))))))
126
127;; Fetches general information about the server
128(define (get-server-info #!optional (server (server)))
129  (send-request server))
130
131
132;; Request method for the document API
133(define (send-document-request database server #!key doc id rev send-body method (headers (alist->headers '())))
134  (unless database (couchdb-error 'send-document-request "No database given (neither argument nor parameter)"))
135
136  (let* ([body (and send-body (with-output-to-string (cute json-write (document-body doc))))]
137         [rev (or rev (and (document? doc) (document-rev doc)))]
138         [id (or id (document-id doc))]
139         [headers (alist->headers '((content-type . (application/json))) headers)]
140         [headers (if body (alist->headers `((content-length . ,(list (string-length body)))) headers) headers)]
141         [headers (if rev (alist->headers `((if-match . ,(list rev))) headers) headers)])
142
143    (handling-client-errors exn (send-request (make-request uri: (uri-path-append server database id)
144                                                            method: method 
145                                                            headers: headers) body)
146
147                            ((404) (last-error! (format "Document ~A doesn't exist in ~A" id 
148                                                        (uri->string (uri-path-append server database))))))))
149
150;; GETs the document with the given id
151(define (get-document id #!optional (database (database)) (server (server)))
152  (and-let* ([response (send-document-request database server id: id method: 'GET)])
153    (avector->document response)))
154
155
156;; DELETEs the document with the given id and revision
157(define (delete-document doc #!optional (database (database)) (server (server)))
158  (let ([id (and (not (document? doc)) doc)])
159    (send-document-request database server doc: doc id: id method: 'DELETE)))
160
161
162;; Saves the given document and returns it with updated id and revision
163(define (save-document doc #!optional (database (database)) (server (server)))
164  (let ([response (send-document-request database server 
165                                         send-body: #t
166                                         method: (if (document-id doc) 'PUT 'POST)
167                                         doc: doc)])
168
169    (and response (update-document doc
170                                   id: (json-ref 'id response)
171                                   rev: (json-ref 'rev response)))))
172
173
174;; Request method for the database API
175(define (send-database-request name server method)
176  (unless name (couchdb-error 'send-database-request "No database given (neither argument nor parameter)"))
177
178  (handling-client-errors exn
179                          (send-request (make-request uri: (uri-path-append server name)
180                                                      method: method))
181                         
182                          ((404) (last-error! (format "Database ~A doesn't exist on ~A" name (uri->string server))))))
183
184;; Creates a new database of the given name
185(define (create-database #!optional (name (database)) (server (server)))
186  (handling-client-errors exn (json-ref 'ok (send-database-request name server 'PUT))
187                          ((412) (last-error! (format "Database ~A already exists on ~A" name (uri->string server))))))
188
189;; Deletes database of given name
190(define (delete-database #!optional (name (database)) (server (server)))
191  (let ([result (send-database-request name server 'DELETE)])
192    (and result (json-ref 'ok result))))
193
194;; Retrieves information about the given database
195(define (get-database-info #!optional (name (database)) (server (server)))
196  (send-database-request name server 'GET)))
197
198
199
Note: See TracBrowser for help on using the repository browser.