diff --git a/CouchDB.cabal b/CouchDB.cabal new file mode 100644 --- /dev/null +++ b/CouchDB.cabal @@ -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 +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -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 diff --git a/src/Database/CouchDB.hs b/src/Database/CouchDB.hs new file mode 100644 --- /dev/null +++ b/src/Database/CouchDB.hs @@ -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" diff --git a/src/Database/CouchDB/HTTP.hs b/src/Database/CouchDB/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Database/CouchDB/HTTP.hs @@ -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 diff --git a/src/Database/CouchDB/JSON.hs b/src/Database/CouchDB/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Database/CouchDB/JSON.hs @@ -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 +