@@ -19,8 +19,7 @@ Library Hs-Source-Dirs: src Build-Depends: - base >= 3 && < 4, mtl, containers, network>=2.2.0.0, HTTP>=3001.1.3, - json>=0.3.3, hslogger>=1.0.5 + base, mtl, containers, network, HTTP>=3001.1.4, json>=0.3.3 ghc-options: -fwarn-incomplete-patterns Extensions: CouchDB.cabal @@ -2,7 +2,7 @@ if [ `hostname` = "wanderlust.local" ]; then echo "Building on wanderlust.local ..." - ./Setup.lhs configure --user --prefix=/Users/arjun/local && \ + ./Setup.lhs configure --user --prefix=/Users/arjun/.local && \ ./Setup.lhs build && \ ./Setup.lhs haddock && \ ./Setup.lhs install build @@ -32,7 +32,6 @@ module Database.CouchDB , queryViewKeys ) where -import System.Log.Logger (errorM) import Database.CouchDB.HTTP import Control.Monad import Control.Monad.Trans (liftIO) src/Database/CouchDB.hs @@ -13,7 +13,6 @@ module Database.CouchDB.HTTP import Data.IORef import Control.Concurrent -import System.Log.Logger (errorM,debugM,infoM) import Network.TCP import Network.Stream import Network.HTTP @@ -46,8 +45,7 @@ instance Monad CouchMonad where m' conn' fail msg = CouchMonad $ \conn -> do - errorM "couchdb" msg - fail "internal error" + fail $ "internal error: " ++ msg instance MonadIO CouchMonad where @@ -94,17 +92,12 @@ request path query method headers body = do let allHeaders = (makeHeaders (length body)) ++ headers conn <- getConn let req = Request url method allHeaders body - liftIO $ debugM "couchdb.http" $ "Starting " ++ show req let retry 0 = do - liftIO $ errorM "couchdb.http" $ "request failed: " ++ show req - fail "server error" + fail $ "server error: " ++ show req retry n = do response <- liftIO $ sendHTTP conn req case response of Left err -> do - liftIO $ infoM "couchdb.http" $ "request failed; " ++ show n ++ - " more tries left. Error code: " ++ show err ++ ", request: " ++ - show req reopenConnection retry (n-1) Right val -> return val src/Database/CouchDB/HTTP.hs @@ -23,15 +23,17 @@ module Database.CouchDB.Unsafe , queryViewKeys ) where -import System.Log.Logger (errorM) import Database.CouchDB.HTTP import Control.Monad import Control.Monad.Trans (liftIO) import Data.Maybe (fromJust,mapMaybe) import Text.JSON - import qualified Data.List as L +assertJSObject :: JSValue -> CouchMonad JSValue +assertJSObject v@(JSObject _) = return v +assertJSObject o = fail $ "expected a JSON object; received: " ++ encode o + couchResponse :: String -> [(String,JSValue)] couchResponse respBody = case decode respBody of Error s -> error s @@ -63,8 +65,8 @@ newNamedDoc :: (JSON a) -- ^Returns 'Left' on a conflict. Returns 'Right' with the -- revision number on success. newNamedDoc dbName docName body = do - r <- request (dbName ++ "/" ++ docName) [] PUT [] - (encode $ showJSON body) + obj <- assertJSObject (showJSON body) + r <- request (dbName ++ "/" ++ docName) [] PUT [] (encode obj) case rspCode r of (2,0,1) -> do let result = couchResponse (rspBody r) @@ -128,7 +130,8 @@ newDoc :: (JSON a) -> a -- ^document body -> CouchMonad (JSString,JSString) -- ^ id and rev of new document newDoc db doc = do - r <- request db [] POST [] (encode $ showJSON doc) + obj <- assertJSObject (showJSON doc) + r <- request db [] POST [] (encode obj) case rspCode r of (2,0,1) -> do let result = couchResponse (rspBody r) src/Database/CouchDB/Unsafe.hs 75ad8606d725138b6132f396fa251ad58bab975a Arjun Guha arjun@cs.brown.edu http://github.com/arjunguha/haskell-couchdb/commit/5fef52b9afd40fe0cf6b3ff86d38989362d54fa5 5fef52b9afd40fe0cf6b3ff86d38989362d54fa5 2008-11-19T07:06:14-08:00 2008-11-19T07:06:14-08:00 CouchDB 0.8.1.0 d297a2c33097541f2d1a481ebe4a75bd5e2d4440 Arjun Guha arjun@cs.brown.edu