From d7df5b22d20102a45e1010c203e0a04d299d15b4 Mon Sep 17 00:00:00 2001
From: Alex Chapman <chapman.alex@gmail.com>
Date: Wed, 1 Oct 2008 10:38:54 +1000
Subject: [PATCH] adding initial couchdb

---
 extra/couchdb/authors.txt          |  1 +
 extra/couchdb/couchdb-tests.factor |  4 +++
 extra/couchdb/couchdb.factor       | 43 ++++++++++++++++++++++++++++++
 3 files changed, 48 insertions(+)
 create mode 100644 extra/couchdb/authors.txt
 create mode 100644 extra/couchdb/couchdb-tests.factor
 create mode 100644 extra/couchdb/couchdb.factor

diff --git a/extra/couchdb/authors.txt b/extra/couchdb/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/couchdb/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/extra/couchdb/couchdb-tests.factor b/extra/couchdb/couchdb-tests.factor
new file mode 100644
index 0000000000..8907c0b811
--- /dev/null
+++ b/extra/couchdb/couchdb-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test couchdb ;
+IN: couchdb.tests
diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor
new file mode 100644
index 0000000000..7e1d97e786
--- /dev/null
+++ b/extra/couchdb/couchdb.factor
@@ -0,0 +1,43 @@
+! 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 ;
+IN: couchdb
+
+TUPLE: server { base string initial: "http://localhost:5984" } ;
+
+TUPLE: db { server server } { name string } ;
+
+: db-path ( db -- path )
+    [ server>> base>> ] [ name>> ] bi "/" swap 3array concat ;
+
+TUPLE: couchdb-error { data assoc } ;
+C: <couchdb-error> couchdb-error
+
+M: couchdb-error error. ( error -- )
+    "CouchDB Error: " write data>>
+    "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* ;
+
+: check-request ( response-data success? -- )
+    [ drop ] [ <couchdb-error> throw ] if ;
+
+: couchdb-put ( request-data url -- json-response success? )
+    <put-request> (http-request) json> swap code>> success? ;
+
+USE: prettyprint 
+
+: (create-db) ( db -- db json success? )
+    f over db-path couchdb-put ;
+
+: create-db ( db -- db )
+    (create-db) check-request ;
+
+: ensure-db ( db -- db )
+    (create-db) [ drop ] [
+        <couchdb-error> dup db-exists-error? [ drop ] [ throw ] if
+    ] if ;