CouchDB 0.8.0.3 → 0.8.0.4
raw patch · 5 files changed
+449/−272 lines, 5 filesdep ~HTTPdep ~base
Dependency ranges changed: HTTP, base
Files
- CouchDB.cabal +5/−5
- README +2/−17
- src/Database/CouchDB.hs +138/−195
- src/Database/CouchDB/Safety.hs +0/−55
- src/Database/CouchDB/Unsafe.hs +304/−0
CouchDB.cabal view
@@ -1,5 +1,5 @@ Name: CouchDB-Version: 0.8.0.3+Version: 0.8.0.4 Cabal-Version: >= 1.2.4 Copyright: Copyright (c) 2008 Arjun Guha and Brendan Hickey License: BSD3@@ -19,12 +19,12 @@ Hs-Source-Dirs: src Build-Depends:- base, mtl, containers, network>=2.2.0.0, HTTP, json>=0.3.3,- hslogger>=1.0.5+ base >= 3 && < 4, mtl, containers, network>=2.2.0.0, HTTP>=3001.1.3, + json>=0.3.3, hslogger>=1.0.5 ghc-options: -fwarn-incomplete-patterns Extensions: Exposed-Modules:- Database.CouchDB Database.CouchDB.JSON Database.CouchDB.Safety+ Database.CouchDB Database.CouchDB.JSON Other-Modules:- Database.CouchDB.HTTP+ Database.CouchDB.HTTP Database.CouchDB.Unsafe
README view
@@ -1,19 +1,4 @@-CouchDB 0.8.0----------------This release is for CouchDB 0.8.0.---HTTP-3001.0.4+CouchDB 0.8.1 ------------- -The HTTP-3001.0.4 library suffers from a memory leak. It doesn't close sockets,-so after opening and closing many connections, your application will have "too-many open files."--This bug can affect any long-running application that uses the CouchDB library.-Until this library is updated, you will have to patch it yourself. Potential-fixes were discussed in this thread on Haskell Cafe:--http://www.haskell.org/pipermail/haskell-cafe/2008-August/046334.html-+This release is for CouchDB 0.8.1.
src/Database/CouchDB.hs view
@@ -5,9 +5,16 @@ , runCouchDB , runCouchDB' -- * Databases+ , DB+ , db+ , isDBString , createDB , dropDB -- * Documents+ , Doc+ , Rev+ , doc+ , isDocString , newNamedDoc , newDoc , updateDoc@@ -27,89 +34,129 @@ 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)+import Data.Maybe (fromJust,mapMaybe,maybeToList) import Text.JSON+import Data.List (elem)+import Data.Maybe (mapMaybe) +import Database.CouchDB.Unsafe (CouchView (..)) import qualified Data.List as L+import qualified Database.CouchDB.Unsafe as U -couchResponse :: String -> [(String,JSValue)]-couchResponse respBody = case decode respBody of- Error s -> error s- Ok r -> fromJSObject r+-- |Database name+data DB = DB String -request' path method = request path [] method [] ""+instance Show DB where+ show (DB s) = s +instance JSON DB where+ readJSON val = do+ s <- readJSON val+ case isDBString s of+ False -> fail "readJSON: not a valid database name"+ True -> return (DB s)++ showJSON (DB s) = showJSON 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 revision number.+data Rev = Rev { unRev :: JSString } deriving (Eq,Ord)++instance Show Rev where+ show (Rev s) = fromJSString s++-- |Document name+data Doc = Doc { unDoc :: JSString } deriving (Eq,Ord)++instance Show Doc where+ show (Doc s) = fromJSString s++instance JSON Doc where+ readJSON (JSString s) | isDocString (fromJSString s) = return (Doc s)+ readJSON _ = fail "readJSON: not a valid document name"++ showJSON (Doc s) = showJSON s++instance Read Doc where+ readsPrec _ str = maybeToList (parseFirst str) where+ parseFirst "" = Nothing+ parseFirst (ch:rest) + | isFirstDocChar ch =+ let (chs',rest') = parseRest rest+ in Just (Doc $ toJSString $ ch:chs',rest)+ | otherwise = Nothing+ parseRest "" = ("","")+ parseRest (ch:rest) + | isDocChar ch =+ let (chs',rest') = parseRest rest+ in (ch:chs',rest')+ | otherwise =+ ("",ch:rest)++-- |Returns a safe document name. Signals an error if the name is+-- invalid.+doc :: String -> Doc+doc docName = case isDocString docName of+ True -> Doc (toJSString docName)+ False -> error $ "doc : invalid docName (" ++ docName ++ ")"++isDocString :: String -> Bool+isDocString [] = False+isDocString (first:rest) = isFirstDocChar first && and (map isDocChar rest)+++ -- |Creates a new database. Throws an exception if the database already -- exists. createDB :: String -> CouchMonad ()-createDB name = do- resp <- request' name PUT- unless (rspCode resp == (2,0,1)) $- error (rspReason resp)+createDB = U.createDB dropDB :: String -> CouchMonad Bool -- ^False if the database does not exist-dropDB name = do- resp <- request' name DELETE- case rspCode resp of- (2,0,0) -> return True- (4,0,4) -> return False- otherwise -> error (rspReason resp)--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.-unsafeNewNamedDoc dbName docName body = do- r <- request (dbName ++ "/" ++ docName) [] PUT [] - (encode $ showJSON body)- case rspCode r of- (2,0,1) -> do- let result = couchResponse (rspBody r)- let (JSString rev) = fromJust $ lookup "rev" result- return (Right $ fromJSString rev)- (4,0,9) -> do- let result = couchResponse (rspBody r)- let (JSObject errorObj) = fromJust $ lookup "error" result- let (JSString reason) = - fromJust $ lookup "reason" (fromJSObject errorObj)- return $ Left (fromJSString reason)- otherwise -> error (show r)-+dropDB = U.dropDB 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+ -> CouchMonad (Either String Rev)+ -- ^Returns 'Left' on a conflict.+newNamedDoc dbName docName body = do+ r <- U.newNamedDoc (show dbName) (show docName) body+ case r of+ Left s -> return (Left s)+ Right rev -> return (Right $ Rev rev) updateDoc :: (JSON a) => DB -- ^database- -> (JSString,JSString) -- ^document and revision+ -> (Doc,Rev) -- ^document and revision -> a -- ^ new value- -> CouchMonad (Maybe (JSString,JSString)) + -> CouchMonad (Maybe (Doc,Rev)) updateDoc db (doc,rev) val = do- let (JSObject obj) = showJSON val- let doc' = fromJSString doc- let obj' = ("_id",JSString doc):("_rev",JSString rev):(fromJSObject obj)- r <- request (show db ++ "/" ++ doc') [] PUT [] (encode $ toJSObject obj')- case rspCode r of- (2,0,1) -> do- let result = couchResponse (rspBody r)- let (JSString rev) = fromJust $ lookup "rev" result- return $ Just (doc,rev)- (4,0,9) -> return Nothing- otherwise -> - error $ "updateDoc error.\n" ++ (show r) ++ rspBody r+ r <- U.updateDoc (show db) (unDoc doc, unRev rev) val+ case r of+ Nothing -> return Nothing+ Just (_,rev) -> return $ Just (doc,Rev rev) -- |Delete a doc by document identifier (revision number not needed). This@@ -118,154 +165,73 @@ forceDeleteDoc :: DB -- ^ database -> Doc -- ^ 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+forceDeleteDoc db doc = U.forceDeleteDoc (show db) (show doc) deleteDoc :: DB -- ^database- -> (JSString,JSString) -- ^document and revision+ -> (Doc,Rev) -> CouchMonad Bool-deleteDoc db (doc,rev) = do - r <- request (show db ++ "/" ++ (fromJSString doc)) - [("rev",fromJSString rev)]- DELETE [] ""- case rspCode r of- (2,0,0) -> return True- -- TODO: figure out which error codes are normal (delete conflicts)- otherwise -> fail $ "deleteDoc failed: " ++ (show r)- +deleteDoc db (doc,rev) = U.deleteDoc (show db) (unDoc doc,unRev rev) newDoc :: (JSON a) => DB -- ^database name -> a -- ^document body- -> CouchMonad (JSString,JSString) -- ^ id and rev of new document-newDoc db doc = do- r <- request (show db) [] POST [] (encode $ showJSON doc)- case rspCode r of- (2,0,1) -> do- let result = couchResponse (rspBody r)- let (JSString rev) = fromJust $ lookup "rev" result- let (JSString id) = fromJust $ lookup "id" result- return (id,rev)- otherwise -> error (show r)+ -> CouchMonad (Doc,Rev) -- ^ id and rev of new document+newDoc db body = do+ (doc,rev) <- U.newDoc (show db) body+ return (Doc doc,Rev rev) getDoc :: (JSON a) => DB -- ^database name -> Doc -- ^document name- -> CouchMonad (Maybe (JSString,JSString,a)) -- ^'Nothing' if the - -- doc does not exist+ -> CouchMonad (Maybe (Doc,Rev,a)) -- ^'Nothing' if the + -- doc does not exist getDoc db doc = do- r <- getDocPrim db doc+ r <- U.getDoc (show db) (show 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-+ Just (_,rev,val) -> return $ Just (doc,Rev rev,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 :: DB -- ^database name -> Doc -- ^document name- -> CouchMonad (Maybe (JSString,JSString,[(String,JSValue)]))+ -> CouchMonad (Maybe (Doc,Rev,[(String,JSValue)])) -- ^'Nothing' if the document does not exist. getDocPrim db doc = do- r <- request' (show db ++ "/" ++ show 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"+ r <- U.getDocPrim (show db) (show doc)+ case r of+ Nothing -> return Nothing+ Just (_,rev,obj) -> return $ Just (doc,Rev rev,obj) getAndUpdateDoc :: (JSON a) => DB -- ^database -> Doc -- ^document name -> (a -> a) -- ^update function- -> CouchMonad (Maybe String) -- ^If the update succeeds,- -- return the revision number- -- of the result.+ -> CouchMonad (Maybe Rev) -- ^If the update succeeds,+ -- return the revision number+ -- of the result. getAndUpdateDoc db docId fn = do- r <- getDoc db docId+ r <- U.getAndUpdateDoc (show db) (show docId) fn case r of- Just (id,rev,val) -> do- r <- updateDoc db (id,rev) (fn val)- case r of- Just (id,rev) -> return (Just $ fromJSString rev)- Nothing -> return Nothing Nothing -> return Nothing---allDocRow :: JSValue -> Maybe String-allDocRow (JSObject row) = case lookup "key" (fromJSObject row) of- Just (JSString s) -> let key = fromJSString s- in case key of- '_':_ -> Nothing- otherwise -> Just key- Just _ -> error $ "key not a string in row " ++ show row- Nothing -> error $ "no key in a row " ++ show row-allDocRow v = error $ "expected row to be an object, received " ++ show v+ Just rev -> return $ Just (Rev $ toJSString rev) getAllDocIds ::DB -- ^database name- -> CouchMonad [String]+ -> CouchMonad [Doc] getAllDocIds db = do- response <- request' (show db ++ "/_all_docs") GET- case rspCode response of- (2,0,0) -> do- let result = couchResponse (rspBody response)- let (JSArray rows) = fromJust $ lookup "rows" result- return $ mapMaybe allDocRow rows- otherwise -> error (show response)+ allIds <- U.getAllDocIds (show db)+ return (map Doc allIds) -- -- $views -- Creating and querying views -- -data CouchView = ViewMap String String- | ViewMapReduce String String String--couchViewToJSON :: CouchView -> (String,JSValue)-couchViewToJSON (ViewMap name fn) = (name,JSObject $ toJSObject fn') where- fn' = [("map", JSString $ toJSString fn)]-couchViewToJSON (ViewMapReduce name m r) =- (name, JSObject $ toJSObject obj) where- obj = [("map", JSString $ toJSString m),- ("reduce", JSString $ toJSString r)]- newView :: String -- ^database name -> String -- ^view set name -> [CouchView] -- ^views -> CouchMonad ()-newView dbName viewName views = do- let body = toJSObject - [("language", JSString $ toJSString "javascript"),- ("views", JSObject $ toJSObject (map couchViewToJSON views))]- result <- unsafeNewNamedDoc dbName ("_design/" ++ viewName) - (JSObject body)- case result of- Right _ -> return ()- Left err -> error err--toRow :: JSON a => JSValue -> (JSString,a)-toRow (JSObject objVal) = (key,value) where- obj = fromJSObject objVal- key = case lookup "id" obj of- Just (JSString s) -> s- Just v -> error $ "toRow: expected id to be a string, got " ++ show v- Nothing -> error $ "toRow: row does not have an id field in " - ++ show obj- value = case lookup "value" obj of- Just v -> case readJSON v of- Ok v' -> v'- Error s -> error s- Nothing -> error $ "toRow: row does not have a value in " ++ show obj-toRow val =- error $ "toRow: expected row to be an object, received " ++ show val+newView = U.newView queryView :: (JSON a) => DB -- ^database@@ -273,17 +239,10 @@ -> Doc -- ^view -> [(String, JSValue)] -- ^query parameters -- |Returns a list of rows. Each row is a key, value pair.- -> CouchMonad [(JSString, a)]+ -> CouchMonad [(Doc, a)] queryView db viewSet view args = do- let args' = map (\(k,v) -> (k,encode v)) args- let url' = concat [show db,"/_view/",show viewSet,"/",show view]- r <- request url' args' GET [] ""- case rspCode r of- (2,0,0) -> do- let result = couchResponse (rspBody r)- let (JSArray rows) = fromJust $ lookup "rows" result- return $ map toRow rows- otherwise -> error (show r)+ rows <- U.queryView (show db) (show viewSet) (show view) args+ return $ map (\(doc,val) -> (Doc doc,val)) rows -- |Like 'queryView', but only returns the keys. Use this for key-only -- views where the value is completely ignored.@@ -291,23 +250,7 @@ -> Doc -- ^design -> Doc -- ^view -> [(String, JSValue)] -- ^query parameters- -> CouchMonad [String]+ -> CouchMonad [Doc] queryViewKeys db viewSet view args = do- let args' = map (\(k,v) -> (k,encode v)) args- let url' = concat [show db,"/_view/",show viewSet,"/",show view]- r <- request url' args' GET [] ""- case rspCode r of- (2,0,0) -> do- let result = couchResponse (rspBody r)- case lookup "rows" result of- Just (JSArray rows) -> liftIO $ mapM rowKey rows- otherwise -> fail $ "queryView: expected rows"- otherwise -> error (show r)--rowKey :: JSValue -> IO String-rowKey (JSObject obj) = do- let assoc = fromJSObject obj- case lookup "id" assoc of- Just (JSString s) -> return (fromJSString s)- v -> fail "expected id"-rowKey v = fail "expected id"+ rows <- U.queryViewKeys (show db) (show viewSet) (show view) args+ return $ map (Doc . toJSString) rows
− src/Database/CouchDB/Safety.hs
@@ -1,55 +0,0 @@--- |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)
+ src/Database/CouchDB/Unsafe.hs view
@@ -0,0 +1,304 @@+-- | an unsafe interface to CouchDB. Database and document names are not+-- sanitized.+module Database.CouchDB.Unsafe+ (+ -- * Databases+ createDB+ , dropDB+ -- * Documents+ , newNamedDoc+ , newDoc+ , updateDoc+ , deleteDoc+ , forceDeleteDoc+ , getDocPrim+ , getDoc+ , getAndUpdateDoc+ , getAllDocIds+ -- * Views+ -- $views+ , CouchView (..)+ , newView+ , queryView+ , 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++couchResponse :: String -> [(String,JSValue)]+couchResponse respBody = case decode respBody of+ Error s -> error s+ Ok r -> fromJSObject r++request' path method = request path [] method [] ""++-- |Creates a new database. Throws an exception if the database already+-- exists. +createDB :: String -> CouchMonad ()+createDB name = do+ resp <- request' name PUT+ unless (rspCode resp == (2,0,1)) $+ error (rspReason resp)++dropDB :: String -> CouchMonad Bool -- ^False if the database does not exist+dropDB name = do+ resp <- request' name DELETE+ case rspCode resp of+ (2,0,0) -> return True+ (4,0,4) -> return False+ otherwise -> error (rspReason resp)++newNamedDoc :: (JSON a)+ => String -- ^database name+ -> String -- ^document name+ -> a -- ^document body+ -> CouchMonad (Either String JSString)+ -- ^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)+ case rspCode r of+ (2,0,1) -> do+ let result = couchResponse (rspBody r)+ let (JSString rev) = fromJust $ lookup "rev" result+ return (Right rev)+ (4,0,9) -> do+ let result = couchResponse (rspBody r)+ let (JSObject errorObj) = fromJust $ lookup "error" result+ let (JSString reason) = + fromJust $ lookup "reason" (fromJSObject errorObj)+ return $ Left (fromJSString reason)+ otherwise -> error (show r)+++updateDoc :: (JSON a)+ => String -- ^database+ -> (JSString,JSString) -- ^document and revision+ -> a -- ^ new value+ -> CouchMonad (Maybe (JSString,JSString)) +updateDoc db (doc,rev) val = do+ 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')+ case rspCode r of+ (2,0,1) -> do+ let result = couchResponse (rspBody r)+ let (JSString rev) = fromJust $ lookup "rev" result+ return $ Just (doc,rev)+ (4,0,9) -> return Nothing+ 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+deleteDoc db (doc,rev) = do + r <- request (db ++ "/" ++ (fromJSString doc)) [("rev",fromJSString rev)]+ DELETE [] ""+ case rspCode r of+ (2,0,0) -> return True+ -- TODO: figure out which error codes are normal (delete conflicts)+ otherwise -> fail $ "deleteDoc failed: " ++ (show r)+ ++newDoc :: (JSON a)+ => String -- ^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)+ case rspCode r of+ (2,0,1) -> do+ let result = couchResponse (rspBody r)+ let (JSString rev) = fromJust $ lookup "rev" result+ let (JSString id) = fromJust $ lookup "id" result+ return (id,rev)+ otherwise -> error (show r)+ +getDoc :: (JSON a)+ => String -- ^database name+ -> String -- ^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)++-- |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+ -> String -- ^document name+ -> (a -> a) -- ^update function+ -> CouchMonad (Maybe String) -- ^If the update succeeds,+ -- return the revision number+ -- of the result.+getAndUpdateDoc db docId fn = do+ r <- getDoc db docId+ case r of+ Just (id,rev,val) -> do+ r <- updateDoc db (id,rev) (fn val)+ case r of+ Just (id,rev) -> return (Just $ fromJSString rev)+ Nothing -> return Nothing+ Nothing -> return Nothing+++allDocRow :: JSValue -> Maybe JSString+allDocRow (JSObject row) = case lookup "key" (fromJSObject row) of+ Just (JSString s) -> let key = fromJSString s+ in case key of+ '_':_ -> Nothing+ otherwise -> Just s+ Just _ -> error $ "key not a string in row " ++ show row+ 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+ -> CouchMonad [JSString]+getAllDocIds db = do+ response <- request' (db ++ "/_all_docs") GET+ case rspCode response of+ (2,0,0) -> do+ let result = couchResponse (rspBody response)+ let (JSArray rows) = fromJust $ lookup "rows" result+ return $ mapMaybe allDocRow rows+ otherwise -> error (show response)++--+-- $views+-- Creating and querying views+--++data CouchView = ViewMap String String+ | ViewMapReduce String String String++couchViewToJSON :: CouchView -> (String,JSValue)+couchViewToJSON (ViewMap name fn) = (name,JSObject $ toJSObject fn') where+ fn' = [("map", JSString $ toJSString fn)]+couchViewToJSON (ViewMapReduce name m r) =+ (name, JSObject $ toJSObject obj) where+ obj = [("map", JSString $ toJSString m),+ ("reduce", JSString $ toJSString r)]++newView :: String -- ^database name+ -> String -- ^view set name+ -> [CouchView] -- ^views+ -> CouchMonad ()+newView dbName viewName views = do+ let body = toJSObject + [("language", JSString $ toJSString "javascript"),+ ("views", JSObject $ toJSObject (map couchViewToJSON views))]+ result <- newNamedDoc dbName ("_design/" ++ viewName) + (JSObject body)+ case result of+ Right _ -> return ()+ Left err -> error err++toRow :: JSON a => JSValue -> (JSString,a)+toRow (JSObject objVal) = (key,value) where+ obj = fromJSObject objVal+ key = case lookup "id" obj of+ Just (JSString s) -> s+ Just v -> error $ "toRow: expected id to be a string, got " ++ show v+ Nothing -> error $ "toRow: row does not have an id field in " + ++ show obj+ value = case lookup "value" obj of+ Just v -> case readJSON v of+ Ok v' -> v'+ Error s -> error s+ Nothing -> error $ "toRow: row does not have a value in " ++ show obj+toRow val =+ error $ "toRow: expected row to be an object, received " ++ show val++queryView :: (JSON a)+ => String -- ^database+ -> String -- ^design+ -> String -- ^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]+ r <- request url' args' GET [] ""+ case rspCode r of+ (2,0,0) -> do+ let result = couchResponse (rspBody r)+ let (JSArray rows) = fromJust $ lookup "rows" result+ return $ map toRow rows+ otherwise -> error (show r)++-- |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+ -> [(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]+ r <- request url' args' GET [] ""+ case rspCode r of+ (2,0,0) -> do+ let result = couchResponse (rspBody r)+ case lookup "rows" result of+ Just (JSArray rows) -> liftIO $ mapM rowKey rows+ otherwise -> fail $ "queryView: expected rows"+ otherwise -> error (show r)++rowKey :: JSValue -> IO String+rowKey (JSObject obj) = do+ let assoc = fromJSObject obj+ case lookup "id" assoc of+ Just (JSString s) -> return (fromJSString s)+ v -> fail "expected id"+rowKey v = fail "expected id"