steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Working minimal couchdb. 

Tests will fail unless couchdb is running.
db4
Alex Chapman 2009-04-15 10:54:10 +10:00
parent 9e4adede5f
commit ab6ba12a2f
2 changed files with 14 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
extra/couchdb/couchdb-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman ! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs couchdb kernel namespaces sequences strings tools.test ; USING: accessors assocs couchdb kernel namespaces sequences strings tools.test ;
IN: couchdb.tests IN: couchdb.tests
! You must have a CouchDB server (currently only the version from svn will ! You must have a CouchDB server (currently only the version from svn will
@ -16,6 +16,7 @@ IN: couchdb.tests
[ ] [ couch get ensure-db ] unit-test [ ] [ couch get ensure-db ] unit-test
[ 0 ] [ couch get db-info "doc_count" swap at ] unit-test [ 0 ] [ couch get db-info "doc_count" swap at ] unit-test
[ ] [ couch get compact-db ] unit-test [ ] [ couch get compact-db ] unit-test
[ t ] [ couch get server>> next-uuid string? ] unit-test
[ ] [ H{ [ ] [ H{
{ "Subject" "I like Planktion" } { "Subject" "I like Planktion" }
{ "Tags" { "plankton" "baseball" "decisions" } } { "Tags" { "plankton" "baseball" "decisions" } }

21
extra/couchdb/couchdb.factor
View File

@ -1,6 +1,9 @@
! Copyright (C) 2008 Alex Chapman ! Copyright (C) 2008, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations debugger hashtables http http.client io json.reader json.writer kernel make math math.parser namespaces sequences strings urls urls.encoding vectors ; USING: accessors arrays assocs continuations debugger hashtables http
http.client io io.encodings.string io.encodings.utf8 json.reader
json.writer kernel make math math.parser namespaces sequences strings
urls urls.encoding vectors ;
IN: couchdb IN: couchdb
! NOTE: This code only works with the latest couchdb (0.9.*), because old ! NOTE: This code only works with the latest couchdb (0.9.*), because old
@ -27,7 +30,7 @@ PREDICATE: file-exists-error < couchdb-error
: couch-http-request ( request -- data ) : couch-http-request ( request -- data )
[ http-request ] [ [ http-request ] [
dup download-failed? [ dup download-failed? [
data>> json> <couchdb-error> throw response>> body>> json> <couchdb-error> throw
] [ ] [
rethrow rethrow
] if ] if
@ -46,7 +49,7 @@ PREDICATE: file-exists-error < couchdb-error
<post-request> couch-request ; <post-request> couch-request ;
: couch-delete ( url -- assoc ) : couch-delete ( url -- assoc )
"DELETE" <client-request> couch-request ; <delete-request> couch-request ;
: response-ok ( assoc -- assoc ) : response-ok ( assoc -- assoc )
"ok" over delete-at* and t assert= ; "ok" over delete-at* and t assert= ;
@ -79,11 +82,11 @@ TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache
: uuids-url ( server -- url ) : uuids-url ( server -- url )
[ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ; [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
: uuids-post ( server -- uuids ) : uuids-get ( server -- uuids )
uuids-url f swap couch-post "uuids" swap at >vector ; uuids-url couch-get "uuids" swap at >vector ;
: get-uuids ( server -- server ) : get-uuids ( server -- server )
dup uuids-post [ nip ] curry change-uuids ; dup uuids-get [ nip ] curry change-uuids ;
: ensure-uuids ( server -- server ) : ensure-uuids ( server -- server )
dup uuids>> empty? [ get-uuids ] when ; dup uuids>> empty? [ get-uuids ] when ;
@ -123,7 +126,7 @@ C: <db> db
db-url "_all_docs" append couch-get ; db-url "_all_docs" append couch-get ;
: <json-post-data> ( assoc -- post-data ) : <json-post-data> ( assoc -- post-data )
>json "application/json" <post-data> swap >>data ; >json utf8 encode "application/json" <post-data> swap >>data ;
! documents ! documents
: id> ( assoc -- id ) "_id" swap at ; : id> ( assoc -- id ) "_id" swap at ;
@ -189,7 +192,7 @@ C: <db> db
! construct-attachment H{ } clone ! construct-attachment H{ } clone
! TODO: ! TODO:
! - startkey, count, descending, etc. ! - startkey, limit, descending, etc.
! - loading specific revisions ! - loading specific revisions
! - views ! - views
! - attachments ! - attachments