1 ! Copyright (C) 2008, 2009 Alex Chapman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs continuations debugger hashtables http
4 http.client io io.encodings.string io.encodings.utf8 json.reader
5 json.writer kernel locals make math math.parser namespaces sequences
6 strings urls urls.encoding vectors ;
9 ! NOTE: This code only works with the latest couchdb (0.9.*), because old
10 ! versions didn't provide the /_uuids feature which this code relies on when
11 ! creating new documents.
14 : with-couch ( db quot -- )
15 couch swap with-variable ; inline
18 TUPLE: couchdb-error { data assoc } ;
19 C: <couchdb-error> couchdb-error
21 M: couchdb-error error. ( error -- )
22 "CouchDB Error: " write data>>
23 "error" over at [ print ] when*
24 "reason" of [ print ] when* ;
26 PREDICATE: file-exists-error < couchdb-error
27 data>> "error" of "file_exists" = ;
30 : couch-http-request ( request -- data )
32 dup download-failed? [
33 response>> body>> json> <couchdb-error> throw
39 : couch-request ( request -- assoc )
40 couch-http-request json> ;
42 : couch-get ( url -- assoc )
43 <get-request> couch-request ;
45 : <json-post-data> ( assoc -- post-data )
46 >json utf8 encode "application/json" <post-data> swap >>data ;
48 : couch-put ( assoc url -- assoc' )
49 [ <json-post-data> ] dip <put-request> couch-request ;
51 : couch-post ( assoc url -- assoc' )
52 [ <json-post-data> ] dip <post-request> couch-request ;
54 : couch-delete ( url -- assoc )
55 <delete-request> couch-request ;
57 : response-ok ( assoc -- assoc )
58 "ok" over delete-at* and t assert= ;
60 : response-ok* ( assoc -- )
64 TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
66 CONSTANT: default-couch-host "localhost"
67 CONSTANT: default-couch-port 5984
68 CONSTANT: default-uuids-to-cache 100
70 : <server> ( host port -- server )
71 V{ } clone default-uuids-to-cache server boa ;
73 : <default-server> ( -- server )
74 default-couch-host default-couch-port <server> ;
76 : (server-url) ( server -- )
77 "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
79 : server-url ( server -- url )
80 [ (server-url) ] "" make ;
82 : all-dbs ( server -- dbs )
83 server-url "_all_dbs" append couch-get ;
85 : uuids-url ( server -- url )
86 [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
88 : uuids-get ( server -- uuids )
89 uuids-url couch-get "uuids" of >vector ;
91 : get-uuids ( server -- server )
92 dup uuids-get [ nip ] curry change-uuids ;
94 : ensure-uuids ( server -- server )
95 dup uuids>> empty? [ get-uuids ] when ;
97 : next-uuid ( server -- uuid )
98 ensure-uuids uuids>> pop ;
101 TUPLE: db { server server } { name string } ;
105 [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
107 : db-url ( db -- url )
108 [ (db-url) ] "" make ;
110 : create-db ( db -- )
111 f swap db-url couch-put response-ok* ;
113 : ensure-db ( db -- )
115 dup file-exists-error? [ 2drop ] [ rethrow ] if
118 : delete-db ( db -- )
119 db-url couch-delete drop ;
121 : db-info ( db -- info )
124 : all-docs ( db -- docs )
125 ! TODO: queries. Maybe pass in a hashtable with options
126 db-url "_all_docs" append couch-get ;
128 : compact-db ( db -- )
129 f swap db-url "_compact" append couch-post response-ok* ;
132 : id> ( assoc -- id ) "_id" of ;
133 : >id ( assoc id -- assoc ) "_id" pick set-at ;
134 : rev> ( assoc -- rev ) "_rev" of ;
135 : >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
136 : attachments> ( assoc -- attachments ) "_attachments" of ;
137 : >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
139 :: copy-key ( to from to-key from-key -- )
143 : copy-id ( to from -- )
144 "_id" "id" copy-key ;
146 : copy-rev ( to from -- )
147 "_rev" "rev" copy-key ;
149 : id-url ( id -- url )
150 couch get db-url swap url-encode-full append ;
152 : doc-url ( assoc -- url )
155 : temp-view ( view -- results )
156 couch get db-url "_temp_view" append couch-post ;
158 : temp-view-map ( map -- results )
159 "map" associate temp-view ;
161 : save-doc-as ( assoc id -- )
162 dupd id-url couch-put response-ok
163 [ copy-id ] [ copy-rev ] 2bi ;
165 : save-new-doc ( assoc -- )
166 couch get server>> next-uuid save-doc-as ;
168 : save-doc ( assoc -- )
169 dup id> [ save-doc-as ] [ save-new-doc ] if* ;
171 : load-doc ( id -- assoc )
174 : delete-doc ( assoc -- deletion-revision )
177 [ "?rev=" % "_rev" of % ] bi
178 ] "" make couch-delete response-ok "rev" of ;
180 : remove-keys ( assoc keys -- )
181 swap [ delete-at ] curry each ;
183 : remove-couch-info ( assoc -- )
184 { "_id" "_rev" "_attachments" } remove-keys ;
186 ! : construct-attachment ( content-type data -- assoc )
187 ! H{ } clone "name" pick set-at "content-type" pick set-at ;
189 ! : add-attachment ( assoc name attachment -- )
190 ! pick attachments> [ H{ } clone ] unless*
192 ! : attach ( assoc name content-type data -- )
193 ! construct-attachment H{ } clone
196 ! - startkey, limit, descending, etc.
197 ! - loading specific revisions
200 ! - bulk insert/update