CouchDB 0.10.1 → 1.2

raw patch · 10 files changed

+284/−57 lines, 10 filesdep +HUnitdep +bytestringdep +utf8-stringsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, bytestring, utf8-string

API changes (from Hackage documentation)

Files

• AUTHORS +4/−0
• CouchDB.cabal +20/−10
• LICENSE +1/−1
• README +3/−3
• Setup.hs +2/−0
• Setup.lhs +0/−13
• src/Database/CouchDB.hs +33/−4
• src/Database/CouchDB/HTTP.hs +66/−18
• src/Database/CouchDB/Unsafe.hs +50/−8
• src/Tests.hs +105/−0

@@ -0,0 +1,4 @@+Arjun Guha+Brendan Hickey+Stephen Maka+Simon Michael

@@ -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 <arjun@cs.brown.edu>+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:     

@@ -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

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 ()

@@ -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

@@ -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

@@ -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

@@ -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 ]+