diff --git a/CouchDB.cabal b/CouchDB.cabal --- a/CouchDB.cabal +++ b/CouchDB.cabal @@ -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 diff --git a/src/Database/CouchDB.hs b/src/Database/CouchDB.hs --- a/src/Database/CouchDB.hs +++ b/src/Database/CouchDB.hs @@ -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 diff --git a/src/Database/CouchDB/HTTP.hs b/src/Database/CouchDB/HTTP.hs --- a/src/Database/CouchDB/HTTP.hs +++ b/src/Database/CouchDB/HTTP.hs @@ -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. diff --git a/src/Database/CouchDB/Safety.hs b/src/Database/CouchDB/Safety.hs new file mode 100644 --- /dev/null +++ b/src/Database/CouchDB/Safety.hs @@ -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)