diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,4 @@ +Arjun Guha +Brendan Hickey +Stephen Maka +Simon Michael diff --git a/CouchDB.cabal b/CouchDB.cabal --- a/CouchDB.cabal +++ b/CouchDB.cabal @@ -1,25 +1,35 @@ Name: CouchDB -Version: 0.10.1 -Cabal-Version: >= 1.2.4 -Copyright: Copyright (c) 2008-2009 Arjun Guha and Brendan Hickey +Version: 1.2 +Cabal-Version: >= 1.8 +Copyright: Copyright (c) 2008-2012. License: BSD3 License-file: LICENSE -Author: Arjun Guha, Brendan Hickey -Maintainer: Arjun Guha +Author: see the AUTHORS file +Maintainer: Homepage: http://github.com/arjunguha/haskell-couchdb/ Stability: provisional Category: Database -Build-Type: Custom +Build-Type: Simple Synopsis: CouchDB interface -Extra-Source-Files: README +Extra-Source-Files: README LICENSE AUTHORS + Description: +Test-Suite test-couchdb + Hs-Source-Dirs: src + Type: exitcode-stdio-1.0 + Main-Is: Tests.hs + Build-Depends: + base >= 4 && < 5, mtl, containers, network, HTTP>=4000.0.4, json>=0.4.3, utf8-string >= 0.3.6 && <= 0.3.7, HUnit, bytestring + Extensions: + FlexibleInstances + ghc-options: + -fwarn-incomplete-patterns Library - Hs-Source-Dirs: - src + Hs-Source-Dirs: src Build-Depends: - base >= 4 && < 5, mtl, containers, network, HTTP>=4000.0.4, json>=0.4.3 + base >= 4 && < 5, mtl, containers, network, HTTP>=4000.0.4, json>=0.4.3, utf8-string >= 0.3.6 && <= 0.3.7, bytestring ghc-options: -fwarn-incomplete-patterns Extensions: diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2008-2009, Arjun Guha and Brendan Hickey. +Copyright (c) 2008-2012, the authors. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README b/README --- a/README +++ b/README @@ -1,4 +1,4 @@ -CouchDB 0.10.0 --------------- +CouchDB 1.2 +------------ -This release is for CouchDB 0.10.0. +This release is for CouchDB 1.2. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,13 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> import System.Directory (setCurrentDirectory) -> import System.Process (runCommand,waitForProcess) - - -> main = defaultMainWithHooks simpleUserHooks { runTests = tests } - -> tests _ _ _ _ = do -> setCurrentDirectory "src" -> h <- runCommand "/usr/bin/env runhaskell Database.CouchDB.Tests" -> waitForProcess h -> return () diff --git a/src/Database/CouchDB.hs b/src/Database/CouchDB.hs --- a/src/Database/CouchDB.hs +++ b/src/Database/CouchDB.hs @@ -4,10 +4,12 @@ CouchMonad , runCouchDB , runCouchDB' + , runCouchDBURI -- * Explicit Connections , CouchConn() , runCouchDBWith , createCouchConn + , createCouchConnFromURI , closeCouchConn -- * Databases , DB @@ -15,6 +17,7 @@ , isDBString , createDB , dropDB + , getAllDBs -- * Documents , Doc , Rev @@ -24,6 +27,7 @@ , newNamedDoc , newDoc , updateDoc + , bulkUpdateDocs , deleteDoc , forceDeleteDoc , getDocPrim @@ -67,18 +71,24 @@ showJSON (DB s) = showJSON s +isDBFirstChar ch = (ch >= 'a' && ch <= 'z') -isDBChar ch = (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') - || (ch >= '0' && ch <= '9') +isDBOtherChar ch = (ch >= 'a' && ch <= 'z') + || (ch >= '0' && ch <= '9') || ch `elem` "_$()+-/" -isFirstDocChar = isDBChar +-- Pretty much anything is accepted in document IDs, but avoid the +-- initial '_' as it is reserved. It is likely possible to accept +-- more, but this includes at least the auto-generated IDs. +isFirstDocChar ch = (ch >= 'A' && ch <='Z') || (ch >= 'a' && ch <= 'z') + || (ch >= '0' && ch <= '9') || ch `elem` "-@." 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) +isDBString (first:[]) = isDBFirstChar first +isDBString (first:rest) = isDBFirstChar first && and (map isDBOtherChar rest) -- |Returns a safe database name. Signals an error if the name is -- invalid. @@ -146,6 +156,10 @@ dropDB :: String -> CouchMonad Bool -- ^False if the database does not exist dropDB = U.dropDB +getAllDBs :: CouchMonad [DB] +getAllDBs = U.getAllDBs + >>= \dbs -> return [db $ fromJSString s | s <- dbs] + newNamedDoc :: (JSON a) => DB -- ^database name -> Doc -- ^document name @@ -169,6 +183,21 @@ Nothing -> return Nothing Just (_,rev) -> return $ Just (doc,Rev rev) +bulkUpdateDocs :: (JSON a) + => DB -- ^database + -> [a] -- ^ new docs + -> CouchMonad (Maybe [Either String (Doc, Rev)]) +bulkUpdateDocs db docs = do + r <- U.bulkUpdateDocs (show db) docs + case r of + Nothing -> return Nothing + Just es -> return $ + Just $ + map (\e -> + case e of + Left err -> Left $ fromJSString err + Right (doc, rev) -> Right (Doc doc, Rev rev) + ) es -- |Delete a doc by document identifier (revision number not needed). This -- operation first retreives the document to get its revision number. It fails 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 @@ -9,8 +9,10 @@ , Response (..) , runCouchDB , runCouchDB' + , runCouchDBURI , CouchConn() , createCouchConn + , createCouchConnFromURI , runCouchDBWith , closeCouchConn ) where @@ -20,16 +22,22 @@ import Network.TCP import Network.HTTP import Network.URI -import Control.Exception (finally) +import Control.Exception (bracket) import Control.Monad.Trans (MonadIO (..)) +import Data.Maybe (fromJust) +import qualified Data.ByteString as BS (ByteString, length) +import qualified Data.ByteString.UTF8 as UTF8 (fromString, toString) +import Network.HTTP.Auth +import Control.Monad (ap) -- |Describes a connection to a CouchDB database. This type is -- encapsulated by 'CouchMonad'. data CouchConn = CouchConn - { ccConn :: IORef (HandleStream String) + { ccConn :: IORef (HandleStream BS.ByteString) , ccURI :: URI , ccHostname :: String , ccPort :: Int + , ccAuth :: Maybe Authority -- ^login credentials, if needed. } -- |A computation that interacts with a CouchDB database. This monad @@ -63,10 +71,13 @@ } ,conn ) -getConn :: CouchMonad (HandleStream String) +getConn :: CouchMonad (HandleStream BS.ByteString) getConn = CouchMonad $ \conn -> do r <- readIORef (ccConn conn) return (r,conn) + +getConnAuth :: CouchMonad (Maybe Authority) +getConnAuth = CouchMonad $ \conn -> return ((ccAuth conn),conn) reopenConnection :: CouchMonad () reopenConnection = CouchMonad $ \conn -> do @@ -77,6 +88,7 @@ makeHeaders bodyLen = [ Header HdrContentType "application/json" + , Header HdrContentEncoding "UTF-8" , Header HdrConnection "keep-alive" , Header HdrContentLength (show bodyLen) ] @@ -91,10 +103,13 @@ -> String -- ^body of the request -> CouchMonad (Response String) request path query method headers body = do + let body' = UTF8.fromString body url <- makeURL path query - let allHeaders = (makeHeaders (length body)) ++ headers + let allHeaders = (makeHeaders (BS.length body')) ++ headers conn <- getConn - let req = Request url method allHeaders body + auth <- getConnAuth + let req' = Request url method allHeaders body' + let req = maybe req' (fillAuth req') auth let retry 0 = do fail $ "server error: " ++ show req retry n = do @@ -103,23 +118,32 @@ Left err -> do reopenConnection retry (n-1) - Right val -> return val + Right val -> return (unUTF8 val) retry 2 + where + unUTF8 :: Response BS.ByteString -> Response String + unUTF8 (Response c r h b) = Response c r h (UTF8.toString b) +fillAuth :: Request a -> Authority -> Request a +fillAuth req auth = req { rqHeaders = new : rqHeaders req } + where new = Header HdrAuthorization (withAuthority auth req) +runCouchDBURI :: URI -- ^URI to connect + -> CouchMonad a + -> IO a +runCouchDBURI uri act = bracket + (createCouchConnFromURI uri) + closeCouchConn + (flip runCouchDBWith act) + 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) "" "" "" - c <- openTCPConnection hostname port - conn <- newIORef c - (a,_) <- m (CouchConn conn baseURI hostname port) - `finally` (do c <- readIORef conn - close c) - return a +runCouchDB hostname port act = bracket + (createCouchConn hostname port) + closeCouchConn + (flip runCouchDBWith act) -- |Connects to the CouchDB server at localhost:5984. runCouchDB' :: CouchMonad a -> IO a @@ -133,13 +157,37 @@ createCouchConn :: String -- ^hostname -> Int -- ^port -> IO (CouchConn) -createCouchConn hostname port = do +createCouchConn hostname port = createCouchAuthConn hostname port Nothing + +-- |Create a CouchDB connection with password authentication for use +-- with runCouchDBWith. +createCouchAuthConn :: String -- ^hostname + -> Int -- ^port + -> Maybe Authority -- ^Login credentials + -> IO (CouchConn) +createCouchAuthConn hostname port auth = do let uriAuth = URIAuth "" hostname (':':(show port)) let baseURI = URI "http:" (Just uriAuth) "" "" "" c <- openTCPConnection hostname port conn <- newIORef c - return (CouchConn conn baseURI hostname port) + return (CouchConn conn baseURI hostname port auth) +-- |Create a CouchDB from an URI connection for use with runCouchDBWith. +createCouchConnFromURI :: URI -- ^URI with possible login credentials + -> IO (CouchConn) +createCouchConnFromURI baseURI = do + createCouchAuthConn hostname port auth + where + ua = fromJust $ uriAuthority baseURI + hostname = uriRegName ua + port = uriAuthPort (Just baseURI) ua + ua2 = (fromJust.parseURIAuthority.uriToAuthorityString) baseURI + auth = (Just AuthBasic) + `ap` (return "") + `ap` (user ua2) + `ap` (password ua2) + `ap` (return baseURI) + -- |Closes an open CouchDB connection closeCouchConn :: CouchConn -> IO () -closeCouchConn (CouchConn conn _ _ _) = readIORef conn >>= close +closeCouchConn (CouchConn conn _ _ _ _ ) = readIORef conn >>= close diff --git a/src/Database/CouchDB/Unsafe.hs b/src/Database/CouchDB/Unsafe.hs --- a/src/Database/CouchDB/Unsafe.hs +++ b/src/Database/CouchDB/Unsafe.hs @@ -5,10 +5,12 @@ -- * Databases createDB , dropDB + , getAllDBs -- * Documents , newNamedDoc , newDoc , updateDoc + , bulkUpdateDocs , deleteDoc , forceDeleteDoc , getDocPrim @@ -28,7 +30,7 @@ import Database.CouchDB.HTTP import Control.Monad import Control.Monad.Trans (liftIO) -import Data.Maybe (fromJust,mapMaybe) +import Data.Maybe (fromJust, mapMaybe, isNothing) import Text.JSON import qualified Data.List as L @@ -60,6 +62,16 @@ (4,0,4) -> return False otherwise -> error (rspReason resp) +getAllDBs :: CouchMonad [JSString] +getAllDBs = do + response <- request' "_all_dbs" GET + case rspCode response of + (2,0,0) -> + case decode (rspBody response) of + Ok (JSArray dbs) -> return [db | JSString db <- dbs] + otherwise -> error "Unexpected couch response" + otherwise -> error (show response) + newNamedDoc :: (JSON a) => String -- ^database name -> String -- ^document name @@ -77,9 +89,9 @@ 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) + let errorObj (JSObject x) = fromJust . lookup "reason"$ fromJSObject x + errorObj x = x + let (JSString reason) = errorObj . fromJust $ lookup "error" result return $ Left (fromJSString reason) otherwise -> error (show r) @@ -103,7 +115,28 @@ otherwise -> error $ "updateDoc error.\n" ++ (show r) ++ rspBody r +bulkUpdateDocs :: (JSON a) + => String -- ^database + -> [a] -- ^ all docs + -> CouchMonad (Maybe [Either JSString (JSString, JSString)]) -- ^ error or (id,rev) +bulkUpdateDocs db docs = do + let obj = [("docs", docs)] + r <- request (db ++ "/_bulk_docs") [] POST [] (encode $ toJSObject obj) + case rspCode r of + (2,0,1) -> do + let Ok results = decode (rspBody r) + return $ Just $ + map (\result -> + case (lookup "id" result, + lookup "rev" result) of + (Just id, Just rev) -> Right (id, rev) + _ -> Left $ fromJust $ lookup "error" result + ) results + (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. @@ -253,14 +286,23 @@ -> [CouchView] -- ^views -> CouchMonad () newView dbName viewName views = do - let body = toJSObject + let content = map couchViewToJSON views + body = toJSObject [("language", JSString $ toJSString "javascript"), - ("views", JSObject $ toJSObject (map couchViewToJSON views))] - result <- newNamedDoc dbName ("_design/" ++ viewName) + ("views", JSObject $ toJSObject content)] + path = "_design/" ++ viewName + result <- newNamedDoc dbName path (JSObject body) case result of Right _ -> return () - Left err -> error err + Left err -> do + let update x = return . toJSObject . map replace $ fromJSObject x + replace ("views", JSObject v) = + ("views", JSObject . toJSObject . unite $ fromJSObject v) + replace x = x + unite x = L.nubBy (\(k1, _) (k2, _) -> k1 == k2) $ content ++ x + res <- getAndUpdateDoc dbName path update + when (isNothing res) (error "newView: creation of the view failed") toRow :: JSON a => JSValue -> (JSString,a) toRow (JSObject objVal) = (key,value) where diff --git a/src/Tests.hs b/src/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Tests.hs @@ -0,0 +1,105 @@ +module Main where + +import Control.Monad.Trans (liftIO) +import Control.Exception (finally) +import Test.HUnit +import Database.CouchDB +import Database.CouchDB.JSON +import Text.JSON +import System.Exit +import Control.Monad + +-- ---------------------------------------------------------------------------- +-- Helper functions +-- + +assertDBEqual :: (Eq a, Show a) => String -> a -> CouchMonad a -> Assertion +assertDBEqual msg v m = do + v' <- runCouchDB' m + assertEqual msg v' v + +instance Assertable (Either String a) where + assert (Left s) = assertFailure s + assert (Right _) = return () + +assertRight :: (Either String a) -> IO a +assertRight (Left s) = assertFailure s >> fail "assertion failed" +assertRight (Right a) = return a + +instance Assertable (Maybe a) where + assert Nothing = assertFailure "expected (Just ...), got Nothing" + assert (Just a) = return () + +assertJust :: Maybe a -> IO a +assertJust (Just v) = return v +assertJust Nothing = do + assertFailure "expected (Just ...), got Nothing" + fail "assertion failed" + +testWithDB :: String -> (DB -> CouchMonad Bool) -> Test +testWithDB testDescription testCase = + TestLabel testDescription $ TestCase $ do + let action = runCouchDB' $ do + createDB "haskellcouchdbtest" + result <- testCase (db "haskellcouchdbtest") + liftIO $ assertBool testDescription result + let teardown = runCouchDB' (dropDB "haskellcouchdbtest") + let failure _ = assertFailure (testDescription ++ "; exception signalled") + action `catch` failure `finally` teardown + +main = do + putStrLn "Running CouchDB test suite..." + results <- runTestTT allTests + when (errors results > 0 || failures results > 0) + exitFailure + putStrLn "Testing complete." + return () + +-- ----------------------------------------------------------------------------- +-- Data definitions for testing +-- + +data Age = Age + { ageName :: String + , ageValue :: Int + } deriving (Eq,Show) + +instance JSON Age where + + showJSON (Age name val) = JSObject $ toJSObject + [ ("name", showJSON name) + , ("age", showJSON val) + ] + + readJSON val = do + obj <- jsonObject val + name <- jsonField "name" obj + age <- jsonField "age" obj + return (Age name age) + +-- ---------------------------------------------------------------------------- +-- Test cases +-- + + +testCreate = TestCase $ assertDBEqual "create/drop database" True $ do + createDB "test1" + dropDB "test1" -- returns True since the database exists. + +people = [ Age "Arjun" 18, Age "Alex" 17 ] + +testNamedDocs = testWithDB "add named documents" $ \mydb -> do + newNamedDoc mydb (doc "arjun") (people !! 0) + newNamedDoc mydb (doc "alex") (people !! 1) + Just (_,_,v1) <- getDoc mydb (doc "arjun") + Just (_,_,v2) <- getDoc mydb (doc "alex") + return $ (v1 == people !! 0) && (v2 == people !! 1) + +testUTF8 = testWithDB "test UTF8 characters" $ \db -> do + newNamedDoc db (doc "d0") (Age "äöüß" 900) + Just (_, _, d) <- getDoc db (doc "d0") + return (ageName d == "äöüß") + + +allTests = TestList [ testCreate, testNamedDocs, testUTF8 ] +