CouchDB (empty) → 0.8.0.1
raw patch · 7 files changed
+504/−0 lines, 7 filesdep +HTTPdep +basedep +containersbuild-type:Customsetup-changed
Dependencies added: HTTP, base, containers, hslogger, json, mtl, network
Files
- CouchDB.cabal +28/−0
- LICENSE +26/−0
- README +19/−0
- Setup.lhs +8/−0
- src/Database/CouchDB.hs +273/−0
- src/Database/CouchDB/HTTP.hs +112/−0
- src/Database/CouchDB/JSON.hs +38/−0
+ CouchDB.cabal view
@@ -0,0 +1,28 @@+Name: CouchDB+Version: 0.8.0.1+Cabal-Version: >= 1.2.4+Copyright: Copyright (c) 2008 Arjun Guha and Brendan Hickey+License: BSD3+License-file: LICENSE+Author: Arjun Guha, Brendan Hickey+Maintainer: Arjun Guha <arjun@cs.brown.edu>+Homepage: http://github.com/arjunguha/haskell-couchdb/+Stability: provisional+Category: Database+Build-Type: Custom+Synopsis: CouchDB interface+Extra-Source-Files: README+Description:++ +Library+ Hs-Source-Dirs:+ src+ Build-Depends:+ base, mtl, containers, network>=2.2.0.0, HTTP, json>=0.3.3,+ hslogger>=1.0.5+ ghc-options:+ -fwarn-incomplete-patterns+ Extensions: + Exposed-Modules:+ Database.CouchDB Database.CouchDB.JSON Database.CouchDB.HTTP
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2008, Arjun Guha and Brendan Hickey+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution.+ * Neither the name of Brown University nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,19 @@+CouchDB 0.8.0+-------------++This release is for CouchDB 0.8.0.+++HTTP-3001.0.4+-------------++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+
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> import qualified Data.List as L+> import System.Directory+> import System.Process (runCommand,waitForProcess)+++> main = defaultMainWithHooks simpleUserHooks
+ src/Database/CouchDB.hs view
@@ -0,0 +1,273 @@+-- |Interface to CouchDB.+module Database.CouchDB + ( -- * Initialization+ CouchMonad+ , runCouchDB+ , runCouchDB'+ -- * Databases+ , createDB+ , dropDB+ -- * Documents+ , newNamedDoc+ , newDoc+ , updateDoc+ , deleteDoc+ , 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 String)+ -- ^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 $ 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)+++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++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)++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 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++getAllDocIds ::String -- ^database name+ -> CouchMonad [String]+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"
+ src/Database/CouchDB/HTTP.hs view
@@ -0,0 +1,112 @@+-- |Maintains a persistent HTTP connection to a CouchDB database server.+-- CouchDB enjoys closing the connection if there is an error (document+-- not found, etc.) In such cases, 'CouchMonad' will automatically+-- reestablish the connection.+module Database.CouchDB.HTTP + ( request+ , RequestMethod (..)+ , CouchMonad+ , Response (..)+ , runCouchDB+ , runCouchDB'+ ) where++import System.Log.Logger (errorM,debugM)+import Network.TCP+import Network.Stream+import Network.HTTP+import Network.URI+import Control.Monad.Trans (MonadIO (..))++-- |Describes a connection to a CouchDB database. This type is+-- encapsulated by 'CouchMonad'.+data CouchConn = CouchConn + { ccConn :: Connection + , ccURI :: URI+ , ccHostname :: String+ , ccPort :: Int+ }++-- |A computation that interacts with a CouchDB database. This monad+-- encapsulates the 'IO' monad, a persistent HTTP connnection to a+-- CouchDB database and enough information to re-open the connection+-- if it is closed.+data CouchMonad a = CouchMonad (CouchConn -> IO (a,CouchConn))++instance Monad CouchMonad where++ return a = CouchMonad $ \conn -> return (a,conn)++ (CouchMonad m) >>= k = CouchMonad $ \conn -> do+ (a,conn') <- m conn+ let (CouchMonad m') = k a+ m' conn'++instance MonadIO CouchMonad where++ liftIO m = CouchMonad $ \conn -> m >>= \a -> return (a,conn)++makeURL :: String -- ^path+ -> [(String,String)]+ -> CouchMonad URI+makeURL path query = CouchMonad $ \conn -> do+ return ( (ccURI conn) { uriPath = '/':path+ , uriQuery = '?':(urlEncodeVars query) + }+ ,conn )++getConn :: CouchMonad Connection+getConn = CouchMonad $ \conn -> return (ccConn conn,conn)++reopenConnection :: CouchMonad ()+reopenConnection = CouchMonad $ \conn -> do+ liftIO $ close (ccConn conn) -- prevent memory leak+ connection <- liftIO $ openTCPPort (ccHostname conn) (ccPort conn)+ return ((), conn {ccConn = connection})++makeHeaders bodyLen =+ [ Header HdrContentType "application/json"+ , Header HdrConnection "keep-alive"+ , Header HdrContentLength (show bodyLen)+ ]++-- |Send a request to the database. If the connection is closed, it is+-- reopened and the request is resent. On other errors, we raise an+-- exception.+request :: String -- ^path of the request+ -> [(String,String)] -- ^dictionary of GET parameters+ -> RequestMethod + -> [Header] + -> String -- ^body of the request+ -> CouchMonad Response+request path query method headers body = do+ 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 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)+ Right response -> return response++runCouchDB :: String -- ^hostname+ -> Int -- ^port+ -> CouchMonad a + -> IO a+runCouchDB hostname port (CouchMonad m) = do+ let uriAuth = URIAuth "" hostname (':':(show port))+ let baseURI = URI "http:" (Just uriAuth) "" "" ""+ conn <- openTCPPort hostname port+ (a,_) <- m (CouchConn conn baseURI hostname port)+ close conn+ return a++-- |Connects to the CouchDB server at localhost:5984.+runCouchDB' :: CouchMonad a -> IO a+runCouchDB' = runCouchDB "127.0.0.1" 5984
+ src/Database/CouchDB/JSON.hs view
@@ -0,0 +1,38 @@+-- |Convenient functions for parsing JSON responses. Use these+-- functions to write the 'readJSON' method of the 'JSON' class.+module Database.CouchDB.JSON+ ( jsonString+ , jsonInt+ , jsonObject+ , jsonField+ , jsonBool+ ) where++import Text.JSON+import Data.Ratio (numerator,denominator)++jsonString :: JSValue -> Result String+jsonString (JSString s) = return (fromJSString s)+jsonString _ = fail "expected a string"++jsonInt :: (Integral n) => JSValue -> Result n+jsonInt (JSRational r) = case (numerator r, denominator r) of+ (n,1) -> return (fromIntegral n)+ otherwise -> fail "expected an integer; got a rational"+jsonInt _ = fail "expected an integer"++jsonObject :: JSValue -> Result [(String,JSValue)]+jsonObject (JSObject obj) = return (fromJSObject obj)+jsonObject v = fail $ "expected an object, got " ++ (show v)++jsonBool :: JSValue -> Result Bool+jsonBool (JSBool b) = return b+jsonBool v = fail $ "expected a boolean value, got " ++ show v++-- |Extract a field as a value of type 'a'. If the field does not+-- exist or cannot be parsed as type 'a', fail.+jsonField :: JSON a => String -> [(String,JSValue)] -> Result a+jsonField field obj = case lookup field obj of+ Just v -> readJSON v+ Nothing -> fail $ "could not find the field " ++ field+