CouchDB 0.8.0.2 → 0.8.0.3
raw patch · 4 files changed
+138/−56 lines, 4 files
Files
- CouchDB.cabal +4/−2
- src/Database/CouchDB.hs +47/−40
- src/Database/CouchDB/HTTP.hs +32/−14
- src/Database/CouchDB/Safety.hs +55/−0
CouchDB.cabal view
@@ -1,5 +1,5 @@ Name: CouchDB-Version: 0.8.0.2+Version: 0.8.0.3 Cabal-Version: >= 1.2.4 Copyright: Copyright (c) 2008 Arjun Guha and Brendan Hickey License: BSD3@@ -25,4 +25,6 @@ -fwarn-incomplete-patterns Extensions: Exposed-Modules:- Database.CouchDB Database.CouchDB.JSON Database.CouchDB.HTTP+ Database.CouchDB Database.CouchDB.JSON Database.CouchDB.Safety+ Other-Modules:+ Database.CouchDB.HTTP
src/Database/CouchDB.hs view
@@ -27,6 +27,7 @@ import System.Log.Logger (errorM) import Database.CouchDB.HTTP+import Database.CouchDB.Safety import Control.Monad import Control.Monad.Trans (liftIO) import Data.Maybe (fromJust,mapMaybe)@@ -57,14 +58,14 @@ (4,0,4) -> return False otherwise -> error (rspReason resp) -newNamedDoc :: (JSON a)+unsafeNewNamedDoc :: (JSON a) => String -- ^database name -> String -- ^document name -> a -- ^document body -> CouchMonad (Either String String) -- ^Returns 'Left' on a conflict. Returns 'Right' with the -- revision number on success.-newNamedDoc dbName docName body = do+unsafeNewNamedDoc dbName docName body = do r <- request (dbName ++ "/" ++ docName) [] PUT [] (encode $ showJSON body) case rspCode r of@@ -81,8 +82,18 @@ otherwise -> error (show r) +newNamedDoc :: (JSON a)+ => DB -- ^database name+ -> Doc -- ^document name+ -> a -- ^document body+ -> CouchMonad (Either String String)+ -- ^Returns 'Left' on a conflict. Returns 'Right' with the+ -- revision number on success.+newNamedDoc dbName docName body = + unsafeNewNamedDoc (show dbName) (show docName) body+ updateDoc :: (JSON a)- => String -- ^database+ => DB -- ^database -> (JSString,JSString) -- ^document and revision -> a -- ^ new value -> CouchMonad (Maybe (JSString,JSString)) @@ -90,7 +101,7 @@ let (JSObject obj) = showJSON val let doc' = fromJSString doc let obj' = ("_id",JSString doc):("_rev",JSString rev):(fromJSObject obj)- r <- request (db ++ "/" ++ doc') [] PUT [] (encode $ toJSObject obj')+ r <- request (show db ++ "/" ++ doc') [] PUT [] (encode $ toJSObject obj') case rspCode r of (2,0,1) -> do let result = couchResponse (rspBody r)@@ -104,8 +115,8 @@ -- |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+forceDeleteDoc :: DB -- ^ database+ -> Doc -- ^ document identifier -> CouchMonad Bool forceDeleteDoc db doc = do r <- getDocPrim db doc@@ -113,11 +124,12 @@ Just (id,rev,_) -> deleteDoc db (id,rev) Nothing -> return False -deleteDoc :: String -- ^database+deleteDoc :: DB -- ^database -> (JSString,JSString) -- ^document and revision -> CouchMonad Bool deleteDoc db (doc,rev) = do - r <- request (db ++ "/" ++ (fromJSString doc)) [("rev",fromJSString rev)]+ r <- request (show db ++ "/" ++ (fromJSString doc)) + [("rev",fromJSString rev)] DELETE [] "" case rspCode r of (2,0,0) -> return True@@ -126,11 +138,11 @@ newDoc :: (JSON a)- => String -- ^database name+ => DB -- ^database name -> a -- ^document body -> CouchMonad (JSString,JSString) -- ^ id and rev of new document newDoc db doc = do- r <- request db [] POST [] (encode $ showJSON doc)+ r <- request (show db) [] POST [] (encode $ showJSON doc) case rspCode r of (2,0,1) -> do let result = couchResponse (rspBody r)@@ -140,32 +152,27 @@ otherwise -> error (show r) getDoc :: (JSON a)- => String -- ^database name- -> String -- ^document name+ => DB -- ^database name+ -> Doc -- ^document name -> CouchMonad (Maybe (JSString,JSString,a)) -- ^'Nothing' if the -- doc does not exist-getDoc dbName docName = do- r <- request' (dbName ++ "/" ++ docName) GET- case rspCode r of- (2,0,0) -> do- let result = couchResponse (rspBody r)- let (JSString rev) = fromJust $ lookup "_rev" result- let (JSString id) = fromJust $ lookup "_id" result- case readJSON (JSObject $ toJSObject result) of- Ok val -> return $ Just (id, rev, val)- val -> fail $ "error parsing: " ++ encode (toJSObject result)- (4,0,4) -> return Nothing -- doc does not exist- otherwise -> error (show r)+getDoc db doc = do+ r <- getDocPrim db doc+ case r of+ Nothing -> return Nothing+ Just (id,rev,val) -> case readJSON (JSObject $ toJSObject val) of+ Ok a -> return $ Just (id,rev,a)+ otherwise -> fail $ "error parsing: " ++ encode val -- |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+getDocPrim :: DB -- ^database name+ -> Doc -- ^document name -> CouchMonad (Maybe (JSString,JSString,[(String,JSValue)])) -- ^'Nothing' if the document does not exist. getDocPrim db doc = do- r <- request' (db ++ "/" ++ doc) GET+ r <- request' (show db ++ "/" ++ show doc) GET case rspCode r of (2,0,0) -> do let obj = couchResponse (rspBody r)@@ -176,8 +183,8 @@ code -> fail $ "getDocPrim: " ++ show code ++ " error" getAndUpdateDoc :: (JSON a)- => String -- ^database- -> String -- ^document name+ => DB -- ^database+ -> Doc -- ^document name -> (a -> a) -- ^update function -> CouchMonad (Maybe String) -- ^If the update succeeds, -- return the revision number@@ -203,10 +210,10 @@ Nothing -> error $ "no key in a row " ++ show row allDocRow v = error $ "expected row to be an object, received " ++ show v -getAllDocIds ::String -- ^database name+getAllDocIds ::DB -- ^database name -> CouchMonad [String] getAllDocIds db = do- response <- request' (db ++ "/_all_docs") GET+ response <- request' (show db ++ "/_all_docs") GET case rspCode response of (2,0,0) -> do let result = couchResponse (rspBody response)@@ -238,7 +245,7 @@ let body = toJSObject [("language", JSString $ toJSString "javascript"), ("views", JSObject $ toJSObject (map couchViewToJSON views))]- result <- newNamedDoc dbName ("_design/" ++ viewName) + result <- unsafeNewNamedDoc dbName ("_design/" ++ viewName) (JSObject body) case result of Right _ -> return ()@@ -261,15 +268,15 @@ error $ "toRow: expected row to be an object, received " ++ show val queryView :: (JSON a)- => String -- ^database- -> String -- ^design- -> String -- ^view+ => DB -- ^database+ -> Doc -- ^design+ -> Doc -- ^view -> [(String, JSValue)] -- ^query parameters -- |Returns a list of rows. Each row is a key, value pair. -> CouchMonad [(JSString, a)] queryView db viewSet view args = do let args' = map (\(k,v) -> (k,encode v)) args- let url' = concat [db,"/_view/",viewSet,"/",view]+ let url' = concat [show db,"/_view/",show viewSet,"/",show view] r <- request url' args' GET [] "" case rspCode r of (2,0,0) -> do@@ -280,14 +287,14 @@ -- |Like 'queryView', but only returns the keys. Use this for key-only -- views where the value is completely ignored.-queryViewKeys :: String -- ^database- -> String -- ^design- -> String -- ^view+queryViewKeys :: DB -- ^database+ -> Doc -- ^design+ -> Doc -- ^view -> [(String, JSValue)] -- ^query parameters -> CouchMonad [String] queryViewKeys db viewSet view args = do let args' = map (\(k,v) -> (k,encode v)) args- let url' = concat [db,"/_view/",viewSet,"/",view]+ let url' = concat [show db,"/_view/",show viewSet,"/",show view] r <- request url' args' GET [] "" case rspCode r of (2,0,0) -> do
src/Database/CouchDB/HTTP.hs view
@@ -11,17 +11,20 @@ , runCouchDB' ) where -import System.Log.Logger (errorM,debugM)+import Data.IORef+import Control.Concurrent+import System.Log.Logger (errorM,debugM,infoM) import Network.TCP import Network.Stream import Network.HTTP import Network.URI+import Control.Exception (finally) import Control.Monad.Trans (MonadIO (..)) -- |Describes a connection to a CouchDB database. This type is -- encapsulated by 'CouchMonad'. data CouchConn = CouchConn - { ccConn :: Connection + { ccConn :: IORef Connection , ccURI :: URI , ccHostname :: String , ccPort :: Int@@ -60,13 +63,16 @@ ,conn ) getConn :: CouchMonad Connection-getConn = CouchMonad $ \conn -> return (ccConn conn,conn)+getConn = CouchMonad $ \conn -> do+ r <- readIORef (ccConn conn)+ return (r,conn) reopenConnection :: CouchMonad () reopenConnection = CouchMonad $ \conn -> do- liftIO $ close (ccConn conn) -- prevent memory leak+ c <- liftIO $ readIORef (ccConn conn) >>= close connection <- liftIO $ openTCPPort (ccHostname conn) (ccPort conn)- return ((), conn {ccConn = connection})+ writeIORef (ccConn conn) connection+ return ((), conn) makeHeaders bodyLen = [ Header HdrContentType "application/json"@@ -87,14 +93,24 @@ url <- makeURL path query let allHeaders = (makeHeaders (length body)) ++ headers conn <- getConn- liftIO $ debugM "couchdb.http" $ concat [show url," ", show method]- response <- liftIO $ sendHTTP conn (Request url method allHeaders body)- case response of- Left connErr -> do- liftIO $ errorM "couchdb.http" ("request failed: " ++ show connErr)- fail "server error"- Right response -> return response+ 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"+ 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+ retry 2 + runCouchDB :: String -- ^hostname -> Int -- ^port -> CouchMonad a @@ -102,9 +118,11 @@ runCouchDB hostname port (CouchMonad m) = do let uriAuth = URIAuth "" hostname (':':(show port)) let baseURI = URI "http:" (Just uriAuth) "" "" ""- conn <- openTCPPort hostname port+ c <- openTCPPort hostname port+ conn <- newIORef c (a,_) <- m (CouchConn conn baseURI hostname port)- close conn+ `finally` (do c <- readIORef conn+ close c) return a -- |Connects to the CouchDB server at localhost:5984.
+ src/Database/CouchDB/Safety.hs view
@@ -0,0 +1,55 @@+-- |Helps prevent injection attacks. At the time of writing, there+-- is no official specification of the naming conventions. So, this is+-- overly conservative.+module Database.CouchDB.Safety + ( DB+ , db+ , isDBString+ , Doc+ , doc+ , isDocString+ ) where++import Data.List (elem)++-- |Database name+data DB = DB String++instance Show DB where+ show (DB s) = s++isDBChar ch = (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') + || (ch >= '0' && ch <= '9')++isFirstDocChar = isDBChar++isDocChar ch = (ch >= 'A' && ch <='Z') || (ch >= 'a' && ch <= 'z') + || (ch >= '0' && ch <= '9') || ch `elem` "@._"++isDBString :: String -> Bool+isDBString [] = False+isDBString s = and (map isDBChar s)++-- |Returns a safe database name. Signals an error if the name is+-- invalid.+db :: String -> DB+db dbName = case isDBString dbName of+ True -> DB dbName+ False -> error $ "db : invalid dbName (" ++ dbName ++ ")"++-- |Document name+data Doc = Doc String++instance Show Doc where+ show (Doc s) = s++-- |Returns a safe document name. Signals an error if the name is+-- invalid.+doc :: String -> Doc+doc docName = case isDocString docName of+ True -> Doc docName+ False -> error $ "doc : invalid docName (" ++ docName ++ ")"++isDocString :: String -> Bool+isDocString [] = False+isDocString (first:rest) = isFirstDocChar first && and (map isDocChar rest)