CouchDB working and able to create/load/save/delete docs

extra/couchdb/couchdb.factor

@@ -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
+! - ...?