CouchDB working and able to create/load/save/delete docs
parent
59e76f4d13
commit
e05db8fc44
|
@ -1,17 +1,17 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs continuations debugger http.client io json.reader json.writer kernel sequences strings urls ;
|
||||
USING: accessors arrays assocs continuations debugger hashtables http http.client io json.reader json.writer kernel make math math.parser namespaces sequences strings urls vectors ;
|
||||
IN: couchdb
|
||||
|
||||
TUPLE: db < url { url url initial: URL" http://localhost:5984" } ;
|
||||
C: <db> db
|
||||
! NOTE: This code only works with the latest couchdb (0.9.*), because old
|
||||
! versions didn't provide the /_uuids feature which this code relies on when
|
||||
! creating new documents.
|
||||
|
||||
! : <default-db>
|
||||
|
||||
: set-db-name ( db name
|
||||
: db-path ( db -- path )
|
||||
[ url>> ] [ name>> ] bi "/" swap 3array concat ;
|
||||
SYMBOL: couch
|
||||
: with-couch ( db quot -- )
|
||||
couch swap with-variable ; inline
|
||||
|
||||
! errors
|
||||
TUPLE: couchdb-error { data assoc } ;
|
||||
C: <couchdb-error> couchdb-error
|
||||
|
||||
|
@ -20,29 +20,164 @@ M: couchdb-error error. ( error -- )
|
|||
"error" over at [ print ] when*
|
||||
"reason" swap at [ print ] when* ;
|
||||
|
||||
PREDICATE: db-exists-error < couchdb-error
|
||||
data>> "error" swap at [
|
||||
"database_already_exists" =
|
||||
] [ f ] if* ;
|
||||
PREDICATE: file-exists-error < couchdb-error
|
||||
data>> "error" swap at "file_exists" = ;
|
||||
|
||||
: check-request ( response-data success? -- )
|
||||
[ drop ] [ <couchdb-error> throw ] if ;
|
||||
! http tools
|
||||
: couch-http-request ( request -- data )
|
||||
[ http-request ] [
|
||||
dup download-failed? [
|
||||
data>> json> <couchdb-error> throw
|
||||
] [
|
||||
rethrow
|
||||
] if
|
||||
] recover nip ;
|
||||
|
||||
: couchdb-put ( request-data url -- json-response success? )
|
||||
<put-request> (http-request) json> swap code>> success? ;
|
||||
: couch-request ( request -- assoc )
|
||||
couch-http-request json> ;
|
||||
|
||||
USE: prettyprint
|
||||
: couch-get ( url -- assoc )
|
||||
<get-request> couch-request ;
|
||||
|
||||
: (create-db) ( db -- db json success? )
|
||||
f over db-path couchdb-put ;
|
||||
: couch-put ( post-data url -- assoc )
|
||||
<put-request> couch-request ;
|
||||
|
||||
: create-db ( db -- db )
|
||||
(create-db) check-request ;
|
||||
: couch-post ( post-data url -- assoc )
|
||||
<post-request> couch-request ;
|
||||
|
||||
: ensure-db ( db -- db )
|
||||
(create-db) [ drop ] [
|
||||
<couchdb-error> dup db-exists-error? [ drop ] [ throw ] if
|
||||
] if ;
|
||||
: couch-delete ( url -- assoc )
|
||||
<delete-request> couch-request ;
|
||||
|
||||
: response-ok ( assoc -- assoc )
|
||||
"ok" over delete-at* and t assert= ;
|
||||
|
||||
: response-ok* ( assoc -- )
|
||||
response-ok drop ;
|
||||
|
||||
! server
|
||||
TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
|
||||
|
||||
: default-couch-host "localhost" ;
|
||||
: default-couch-port 5984 ;
|
||||
: default-uuids-to-cache 100 ;
|
||||
|
||||
: <server> ( host port -- server )
|
||||
V{ } clone default-uuids-to-cache server boa ;
|
||||
|
||||
: <default-server> ( -- server )
|
||||
default-couch-host default-couch-port <server> ;
|
||||
|
||||
: (server-url) ( server -- )
|
||||
"http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
|
||||
|
||||
: server-url ( server -- url )
|
||||
[ (server-url) ] "" make ;
|
||||
|
||||
: all-dbs ( server -- dbs )
|
||||
server-url "_all_dbs" append couch-get ;
|
||||
|
||||
: uuids-url ( server -- url )
|
||||
[ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
|
||||
|
||||
: uuids-post ( server -- uuids )
|
||||
uuids-url f swap couch-post "uuids" swap at >vector ;
|
||||
|
||||
: get-uuids ( server -- server )
|
||||
dup uuids-post [ nip ] curry change-uuids ;
|
||||
|
||||
: ensure-uuids ( server -- server )
|
||||
dup uuids>> empty? [ get-uuids ] when ;
|
||||
|
||||
: next-uuid ( server -- uuid )
|
||||
ensure-uuids uuids>> pop ;
|
||||
|
||||
! db
|
||||
TUPLE: db { server server } { name string } ;
|
||||
C: <db> db
|
||||
|
||||
: (db-url) ( db -- )
|
||||
[ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
|
||||
|
||||
: db-url ( db -- url )
|
||||
[ (db-url) ] "" make ;
|
||||
|
||||
: create-db ( db -- )
|
||||
f swap db-url couch-put response-ok* ;
|
||||
|
||||
: ensure-db ( db -- )
|
||||
[ create-db ] [
|
||||
dup file-exists-error? [ 2drop ] [ rethrow ] if
|
||||
] recover ;
|
||||
|
||||
: delete-db ( db -- )
|
||||
|
||||
db-url couch-delete drop ;
|
||||
|
||||
: db-info ( db -- info )
|
||||
db-url couch-get ;
|
||||
|
||||
: compact-db ( db -- )
|
||||
f swap db-url "_compact" append couch-post response-ok* ;
|
||||
|
||||
: all-docs ( db -- docs )
|
||||
! TODO: queries. Maybe pass in a hashtable with options
|
||||
db-url "_all_docs" append couch-get ;
|
||||
|
||||
: <json-post-data> ( assoc -- post-data )
|
||||
>json "application/json" <post-data> ;
|
||||
|
||||
! documents
|
||||
: id> ( assoc -- id ) "_id" swap at ;
|
||||
: >id ( assoc id -- assoc ) "_id" pick set-at ;
|
||||
: rev> ( assoc -- rev ) "_rev" swap at ;
|
||||
: >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
|
||||
|
||||
: copy-key ( to from to-key from-key -- )
|
||||
rot at spin set-at ;
|
||||
|
||||
: copy-id ( to from -- )
|
||||
"_id" "id" copy-key ;
|
||||
|
||||
: copy-rev ( to from -- )
|
||||
"_rev" "rev" copy-key ;
|
||||
|
||||
: id-url ( id -- url )
|
||||
couch get db-url swap append ;
|
||||
|
||||
: doc-url ( assoc -- url )
|
||||
id> id-url ;
|
||||
|
||||
: new-doc-url ( -- url )
|
||||
couch get [ db-url ] [ server>> next-uuid ] bi append ;
|
||||
|
||||
: save-new ( assoc -- )
|
||||
dup <json-post-data> new-doc-url couch-put response-ok
|
||||
[ copy-id ] [ copy-rev ] 2bi ;
|
||||
|
||||
: save-existing ( assoc id -- )
|
||||
[ dup <json-post-data> ] dip id-url couch-put response-ok copy-rev ;
|
||||
|
||||
: save ( assoc -- )
|
||||
dup id> [ save-existing ] [ save-new ] if* ;
|
||||
|
||||
: load ( id -- assoc )
|
||||
id-url couch-get ;
|
||||
|
||||
: delete ( assoc -- )
|
||||
[
|
||||
[ doc-url % ]
|
||||
[ "?rev=" % "_rev" swap at % ] bi
|
||||
] "" make couch-delete response-ok* ;
|
||||
|
||||
: remove-keys ( assoc keys -- )
|
||||
swap [ delete-at ] curry each ;
|
||||
|
||||
: remove-couch-info ( assoc -- )
|
||||
{ "_id" "_rev" "_attachments" } remove-keys ;
|
||||
|
||||
! TODO:
|
||||
! - startkey, count, descending, etc.
|
||||
! - loading specific revisions
|
||||
! - views
|
||||
! - attachments
|
||||
! - bulk insert/update
|
||||
! - ...?
|
||||
|
|
Loading…
Reference in New Issue