CouchDB 0.8.0.1 → 0.8.0.2

raw patch · 4 files changed

+46/−7 lines, 4 files

Files

• CouchDB.cabal +1/−1
• src/Database/CouchDB.hs +33/−0
• src/Database/CouchDB/HTTP.hs +6/−6
• src/Database/CouchDB/JSON.hs +6/−0

@@ -1,5 +1,5 @@ Name:           CouchDB-Version:        0.8.0.1+Version:        0.8.0.2 Cabal-Version:	>= 1.2.4 Copyright:      Copyright (c) 2008 Arjun Guha and Brendan Hickey License:        BSD3

@@ -12,6 +12,8 @@   , newDoc   , updateDoc   , deleteDoc+  , forceDeleteDoc+  , getDocPrim   , getDoc   , getAndUpdateDoc   , getAllDocIds@@ -98,6 +100,19 @@     otherwise ->        error $ "updateDoc error.\n" ++ (show r) ++ rspBody r ++-- |Delete a doc by document identifier (revision number not needed).  This+-- operation first retreives the document to get its revision number.  It fails+-- if the document doesn't exist or there is a conflict.+forceDeleteDoc :: String -- ^ database+               -> String -- ^ document identifier+               -> CouchMonad Bool+forceDeleteDoc db doc = do+  r <- getDocPrim db doc+  case r of+    Just (id,rev,_) -> deleteDoc db (id,rev)+    Nothing -> return False+ deleteDoc :: String  -- ^database           -> (JSString,JSString) -- ^document and revision           -> CouchMonad Bool@@ -141,6 +156,24 @@         val -> fail $ "error parsing: " ++ encode (toJSObject result)     (4,0,4) -> return Nothing -- doc does not exist     otherwise -> error (show r)++-- |Gets a document as a raw JSON value.  Returns the document id,+-- revision and value as a 'JSObject'.  These fields are queried lazily,+-- and may fail later if the response from the server is malformed.+getDocPrim :: String -- ^database name+           -> String -- ^document name+           -> CouchMonad (Maybe (JSString,JSString,[(String,JSValue)]))+           -- ^'Nothing' if the document does not exist.+getDocPrim db doc = do+  r <- request' (db ++ "/" ++ doc) GET+  case rspCode r of+    (2,0,0) -> do+      let obj = couchResponse (rspBody r)+      let ~(JSString rev) = fromJust $ lookup "_rev" obj+      let ~(JSString id) = fromJust $ lookup "_id" obj+      return $ Just (id,rev,obj)+    (4,0,4) -> return Nothing -- doc does not exist+    code -> fail $ "getDocPrim: " ++ show code ++ " error"  getAndUpdateDoc :: (JSON a)                 => String -- ^database

@@ -42,6 +42,10 @@     let (CouchMonad m') = k a     m' conn' +  fail msg = CouchMonad $ \conn -> do+    errorM "couchdb" msg+    fail "internal error"   + instance MonadIO CouchMonad where    liftIO m = CouchMonad $ \conn -> m >>= \a -> return (a,conn)@@ -86,13 +90,9 @@   liftIO $ debugM "couchdb.http" $ concat [show url," ", show method]   response <- liftIO $ sendHTTP conn (Request url method allHeaders body)   case response of-    Left ErrorClosed -> do-      liftIO $ errorM "couchdb.http" "connection closed; reopening"-      reopenConnection-      request path query method headers body     Left connErr -> do-      liftIO $ errorM "couchdb.http" ("send failed: " ++ show connErr)-      fail (show connErr)+      liftIO $ errorM "couchdb.http" ("request failed: " ++ show connErr)+      fail "server error"     Right response -> return response  runCouchDB :: String -- ^hostname

@@ -6,6 +6,7 @@   , jsonObject   , jsonField   , jsonBool+  , jsonIsTrue   ) where  import Text.JSON@@ -36,3 +37,8 @@   Just v -> readJSON v   Nothing -> fail $ "could not find the field " ++ field +-- |'True' when the field is defined and is true.  Otherwise, 'False'.+jsonIsTrue :: String -> [(String,JSValue)] -> Result Bool+jsonIsTrue field obj = case lookup field obj of+  Just (JSBool True) -> return True+  otherwise -> return False