├── .gitignore ├── AUTHORS ├── CouchDB.cabal ├── LICENSE ├── README └── src ├── Database ├── CouchDB.hs └── CouchDB │ ├── HTTP.hs │ ├── JSON.hs │ └── Unsafe.hs └── Tests.hs /.gitignore: -------------------------------------------------------------------------------- 1 | /dist 2 | .DS_Store 3 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Arjun Guha 2 | Brendan Hickey 3 | Stephan Maka 4 | Simon Michael 5 | -------------------------------------------------------------------------------- /CouchDB.cabal: -------------------------------------------------------------------------------- 1 | Name: CouchDB 2 | Version: 1.2 3 | Cabal-Version: >= 1.8 4 | Copyright: Copyright (c) 2008-2012. 5 | License: BSD3 6 | License-file: LICENSE 7 | Author: see the AUTHORS file 8 | Maintainer: 9 | Homepage: http://github.com/arjunguha/haskell-couchdb/ 10 | Stability: provisional 11 | Category: Database 12 | Build-Type: Simple 13 | Synopsis: CouchDB interface 14 | Extra-Source-Files: README LICENSE AUTHORS 15 | 16 | Description: 17 | 18 | Test-Suite test-couchdb 19 | Hs-Source-Dirs: src 20 | Type: exitcode-stdio-1.0 21 | Main-Is: Tests.hs 22 | Build-Depends: 23 | base >= 4 && < 5, mtl, containers, network, HTTP>=4000.0.4, json>=0.4.3, utf8-string >= 0.3.6 && <= 0.3.7, HUnit, bytestring 24 | Extensions: 25 | FlexibleInstances 26 | ghc-options: 27 | -fwarn-incomplete-patterns 28 | 29 | Library 30 | Hs-Source-Dirs: src 31 | Build-Depends: 32 | base >= 4 && < 5, mtl, containers, network, HTTP>=4000.0.4, json>=0.4.3, utf8-string >= 0.3.6 && <= 0.3.7, bytestring 33 | ghc-options: 34 | -fwarn-incomplete-patterns 35 | Extensions: 36 | Exposed-Modules: 37 | Database.CouchDB Database.CouchDB.JSON 38 | Other-Modules: 39 | Database.CouchDB.HTTP Database.CouchDB.Unsafe 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008-2012, the authors. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, 8 | this list of conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | * Neither the name of Brown University nor the names of its contributors 13 | may be used to endorse or promote products derived from this software 14 | without specific prior written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 19 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE 20 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 21 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 22 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 23 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 24 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 25 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | CouchDB 1.2 2 | ------------ 3 | 4 | This release is for CouchDB 1.2. 5 | -------------------------------------------------------------------------------- /src/Database/CouchDB.hs: -------------------------------------------------------------------------------- 1 | -- |Interface to CouchDB. 2 | module Database.CouchDB 3 | ( -- * Initialization 4 | CouchMonad 5 | , runCouchDB 6 | , runCouchDB' 7 | , runCouchDBURI 8 | -- * Explicit Connections 9 | , CouchConn() 10 | , runCouchDBWith 11 | , createCouchConn 12 | , createCouchConnFromURI 13 | , closeCouchConn 14 | -- * Databases 15 | , DB 16 | , db 17 | , isDBString 18 | , createDB 19 | , dropDB 20 | , getAllDBs 21 | -- * Documents 22 | , Doc 23 | , Rev 24 | , doc 25 | , rev 26 | , isDocString 27 | , newNamedDoc 28 | , newDoc 29 | , updateDoc 30 | , bulkUpdateDocs 31 | , deleteDoc 32 | , forceDeleteDoc 33 | , getDocPrim 34 | , getDocRaw 35 | , getDoc 36 | , getAllDocs 37 | , getAndUpdateDoc 38 | , getAllDocIds 39 | -- * Views 40 | -- $views 41 | , CouchView (..) 42 | , newView 43 | , queryView 44 | , queryViewKeys 45 | ) where 46 | 47 | import Database.CouchDB.HTTP 48 | import Control.Monad 49 | import Control.Monad.Trans (liftIO) 50 | import Data.Maybe (fromJust,mapMaybe,maybeToList) 51 | import Text.JSON 52 | import Data.List (elem) 53 | import Data.Maybe (mapMaybe) 54 | 55 | import Database.CouchDB.Unsafe (CouchView (..)) 56 | import qualified Data.List as L 57 | import qualified Database.CouchDB.Unsafe as U 58 | 59 | -- |Database name 60 | data DB = DB String 61 | 62 | instance Show DB where 63 | show (DB s) = s 64 | 65 | instance JSON DB where 66 | readJSON val = do 67 | s <- readJSON val 68 | case isDBString s of 69 | False -> fail "readJSON: not a valid database name" 70 | True -> return (DB s) 71 | 72 | showJSON (DB s) = showJSON s 73 | 74 | isDBFirstChar ch = (ch >= 'a' && ch <= 'z') 75 | 76 | isDBOtherChar ch = (ch >= 'a' && ch <= 'z') 77 | || (ch >= '0' && ch <= '9') || ch `elem` "_$()+-/" 78 | 79 | -- Pretty much anything is accepted in document IDs, but avoid the 80 | -- initial '_' as it is reserved. It is likely possible to accept 81 | -- more, but this includes at least the auto-generated IDs. 82 | isFirstDocChar ch = (ch >= 'A' && ch <='Z') || (ch >= 'a' && ch <= 'z') 83 | || (ch >= '0' && ch <= '9') || ch `elem` "-@." 84 | 85 | isDocChar ch = (ch >= 'A' && ch <='Z') || (ch >= 'a' && ch <= 'z') 86 | || (ch >= '0' && ch <= '9') || ch `elem` "-@._" 87 | 88 | isDBString :: String -> Bool 89 | isDBString [] = False 90 | isDBString (first:[]) = isDBFirstChar first 91 | isDBString (first:rest) = isDBFirstChar first && and (map isDBOtherChar rest) 92 | 93 | -- |Returns a safe database name. Signals an error if the name is 94 | -- invalid. 95 | db :: String -> DB 96 | db dbName = case isDBString dbName of 97 | True -> DB dbName 98 | False -> error $ "db : invalid dbName (" ++ dbName ++ ")" 99 | 100 | -- |Document revision number. 101 | data Rev = Rev { unRev :: JSString } deriving (Eq,Ord) 102 | 103 | instance Show Rev where 104 | show (Rev s) = fromJSString s 105 | 106 | -- |Document name 107 | data Doc = Doc { unDoc :: JSString } deriving (Eq,Ord) 108 | 109 | instance Show Doc where 110 | show (Doc s) = fromJSString s 111 | 112 | instance JSON Doc where 113 | readJSON (JSString s) | isDocString (fromJSString s) = return (Doc s) 114 | readJSON _ = fail "readJSON: not a valid document name" 115 | 116 | showJSON (Doc s) = showJSON s 117 | 118 | instance Read Doc where 119 | readsPrec _ str = maybeToList (parseFirst str) where 120 | parseFirst "" = Nothing 121 | parseFirst (ch:rest) 122 | | isFirstDocChar ch = 123 | let (chs',rest') = parseRest rest 124 | in Just (Doc $ toJSString $ ch:chs',rest) 125 | | otherwise = Nothing 126 | parseRest "" = ("","") 127 | parseRest (ch:rest) 128 | | isDocChar ch = 129 | let (chs',rest') = parseRest rest 130 | in (ch:chs',rest') 131 | | otherwise = 132 | ("",ch:rest) 133 | 134 | -- |Returns a Rev 135 | rev :: String -> Rev 136 | rev = Rev . toJSString 137 | 138 | -- |Returns a safe document name. Signals an error if the name is 139 | -- invalid. 140 | doc :: String -> Doc 141 | doc docName = case isDocString docName of 142 | True -> Doc (toJSString docName) 143 | False -> error $ "doc : invalid docName (" ++ docName ++ ")" 144 | 145 | isDocString :: String -> Bool 146 | isDocString [] = False 147 | isDocString (first:rest) = isFirstDocChar first && and (map isDocChar rest) 148 | 149 | 150 | 151 | -- |Creates a new database. Throws an exception if the database already 152 | -- exists. 153 | createDB :: String -> CouchMonad () 154 | createDB = U.createDB 155 | 156 | dropDB :: String -> CouchMonad Bool -- ^False if the database does not exist 157 | dropDB = U.dropDB 158 | 159 | getAllDBs :: CouchMonad [DB] 160 | getAllDBs = U.getAllDBs 161 | >>= \dbs -> return [db $ fromJSString s | s <- dbs] 162 | 163 | newNamedDoc :: (JSON a) 164 | => DB -- ^database name 165 | -> Doc -- ^document name 166 | -> a -- ^document body 167 | -> CouchMonad (Either String Rev) 168 | -- ^Returns 'Left' on a conflict. 169 | newNamedDoc dbName docName body = do 170 | r <- U.newNamedDoc (show dbName) (show docName) body 171 | case r of 172 | Left s -> return (Left s) 173 | Right rev -> return (Right $ Rev rev) 174 | 175 | updateDoc :: (JSON a) 176 | => DB -- ^database 177 | -> (Doc,Rev) -- ^document and revision 178 | -> a -- ^ new value 179 | -> CouchMonad (Maybe (Doc,Rev)) 180 | updateDoc db (doc,rev) val = do 181 | r <- U.updateDoc (show db) (unDoc doc, unRev rev) val 182 | case r of 183 | Nothing -> return Nothing 184 | Just (_,rev) -> return $ Just (doc,Rev rev) 185 | 186 | bulkUpdateDocs :: (JSON a) 187 | => DB -- ^database 188 | -> [a] -- ^ new docs 189 | -> CouchMonad (Maybe [Either String (Doc, Rev)]) 190 | bulkUpdateDocs db docs = do 191 | r <- U.bulkUpdateDocs (show db) docs 192 | case r of 193 | Nothing -> return Nothing 194 | Just es -> return $ 195 | Just $ 196 | map (\e -> 197 | case e of 198 | Left err -> Left $ fromJSString err 199 | Right (doc, rev) -> Right (Doc doc, Rev rev) 200 | ) es 201 | 202 | -- |Delete a doc by document identifier (revision number not needed). This 203 | -- operation first retreives the document to get its revision number. It fails 204 | -- if the document doesn't exist or there is a conflict. 205 | forceDeleteDoc :: DB -- ^ database 206 | -> Doc -- ^ document identifier 207 | -> CouchMonad Bool 208 | forceDeleteDoc db doc = U.forceDeleteDoc (show db) (show doc) 209 | 210 | deleteDoc :: DB -- ^database 211 | -> (Doc,Rev) 212 | -> CouchMonad Bool 213 | deleteDoc db (doc,rev) = U.deleteDoc (show db) (unDoc doc,unRev rev) 214 | 215 | newDoc :: (JSON a) 216 | => DB -- ^database name 217 | -> a -- ^document body 218 | -> CouchMonad (Doc,Rev) -- ^ id and rev of new document 219 | newDoc db body = do 220 | (doc,rev) <- U.newDoc (show db) body 221 | return (Doc doc,Rev rev) 222 | 223 | getDoc :: (JSON a) 224 | => DB -- ^database name 225 | -> Doc -- ^document name 226 | -> CouchMonad (Maybe (Doc,Rev,a)) -- ^'Nothing' if the 227 | -- doc does not exist 228 | getDoc db doc = do 229 | r <- U.getDoc (show db) (show doc) 230 | case r of 231 | Nothing -> return Nothing 232 | Just (_,rev,val) -> return $ Just (doc,Rev rev,val) 233 | 234 | 235 | getAllDocs :: JSON a 236 | => DB 237 | -> [(String, JSValue)] -- ^query parameters 238 | -> CouchMonad [(Doc, a)] 239 | getAllDocs db args = do 240 | rows <- U.getAllDocs (show db) args 241 | return $ map (\(doc,val) -> (Doc doc,val)) rows 242 | 243 | 244 | -- |Gets a document as a raw JSON value. Returns the document id, 245 | -- revision and value as a 'JSObject'. These fields are queried lazily, 246 | -- and may fail later if the response from the server is malformed. 247 | getDocPrim :: DB -- ^database name 248 | -> Doc -- ^document name 249 | -> CouchMonad (Maybe (Doc,Rev,[(String,JSValue)])) 250 | -- ^'Nothing' if the document does not exist. 251 | getDocPrim db doc = do 252 | r <- U.getDocPrim (show db) (show doc) 253 | case r of 254 | Nothing -> return Nothing 255 | Just (_,rev,obj) -> return $ Just (doc,Rev rev,obj) 256 | 257 | getDocRaw :: DB -> Doc -> CouchMonad (Maybe String) 258 | getDocRaw db doc = U.getDocRaw (show db) (show doc) 259 | 260 | getAndUpdateDoc :: (JSON a) 261 | => DB -- ^database 262 | -> Doc -- ^document name 263 | -> (a -> IO a) -- ^update function 264 | -> CouchMonad (Maybe Rev) -- ^If the update succeeds, 265 | -- return the revision number 266 | -- of the result. 267 | getAndUpdateDoc db docId fn = do 268 | r <- U.getAndUpdateDoc (show db) (show docId) fn 269 | case r of 270 | Nothing -> return Nothing 271 | Just rev -> return $ Just (Rev $ toJSString rev) 272 | 273 | getAllDocIds ::DB -- ^database name 274 | -> CouchMonad [Doc] 275 | getAllDocIds db = do 276 | allIds <- U.getAllDocIds (show db) 277 | return (map Doc allIds) 278 | 279 | -- 280 | -- $views 281 | -- Creating and querying views 282 | -- 283 | 284 | newView :: String -- ^database name 285 | -> String -- ^view set name 286 | -> [CouchView] -- ^views 287 | -> CouchMonad () 288 | newView = U.newView 289 | 290 | queryView :: (JSON a) 291 | => DB -- ^database 292 | -> Doc -- ^design 293 | -> Doc -- ^view 294 | -> [(String, JSValue)] -- ^query parameters 295 | -- |Returns a list of rows. Each row is a key, value pair. 296 | -> CouchMonad [(Doc, a)] 297 | queryView db viewSet view args = do 298 | rows <- U.queryView (show db) (show viewSet) (show view) args 299 | return $ map (\(doc,val) -> (Doc doc,val)) rows 300 | 301 | -- |Like 'queryView', but only returns the keys. Use this for key-only 302 | -- views where the value is completely ignored. 303 | queryViewKeys :: DB -- ^database 304 | -> Doc -- ^design 305 | -> Doc -- ^view 306 | -> [(String, JSValue)] -- ^query parameters 307 | -> CouchMonad [Doc] 308 | queryViewKeys db viewSet view args = do 309 | rows <- U.queryViewKeys (show db) (show viewSet) (show view) args 310 | return $ map (Doc . toJSString) rows 311 | -------------------------------------------------------------------------------- /src/Database/CouchDB/HTTP.hs: -------------------------------------------------------------------------------- 1 | -- |Maintains a persistent HTTP connection to a CouchDB database server. 2 | -- CouchDB enjoys closing the connection if there is an error (document 3 | -- not found, etc.) In such cases, 'CouchMonad' will automatically 4 | -- reestablish the connection. 5 | module Database.CouchDB.HTTP 6 | ( request 7 | , RequestMethod (..) 8 | , CouchMonad 9 | , Response (..) 10 | , runCouchDB 11 | , runCouchDB' 12 | , runCouchDBURI 13 | , CouchConn() 14 | , createCouchConn 15 | , createCouchConnFromURI 16 | , runCouchDBWith 17 | , closeCouchConn 18 | ) where 19 | 20 | import Data.IORef 21 | import Control.Concurrent 22 | import Network.TCP 23 | import Network.HTTP 24 | import Network.URI 25 | import Control.Exception (bracket) 26 | import Control.Monad.Trans (MonadIO (..)) 27 | import Data.Maybe (fromJust) 28 | import qualified Data.ByteString as BS (ByteString, length) 29 | import qualified Data.ByteString.UTF8 as UTF8 (fromString, toString) 30 | import Network.HTTP.Auth 31 | import Control.Monad (ap) 32 | 33 | -- |Describes a connection to a CouchDB database. This type is 34 | -- encapsulated by 'CouchMonad'. 35 | data CouchConn = CouchConn 36 | { ccConn :: IORef (HandleStream BS.ByteString) 37 | , ccURI :: URI 38 | , ccHostname :: String 39 | , ccPort :: Int 40 | , ccAuth :: Maybe Authority -- ^login credentials, if needed. 41 | } 42 | 43 | -- |A computation that interacts with a CouchDB database. This monad 44 | -- encapsulates the 'IO' monad, a persistent HTTP connnection to a 45 | -- CouchDB database and enough information to re-open the connection 46 | -- if it is closed. 47 | data CouchMonad a = CouchMonad (CouchConn -> IO (a,CouchConn)) 48 | 49 | instance Monad CouchMonad where 50 | 51 | return a = CouchMonad $ \conn -> return (a,conn) 52 | 53 | (CouchMonad m) >>= k = CouchMonad $ \conn -> do 54 | (a,conn') <- m conn 55 | let (CouchMonad m') = k a 56 | m' conn' 57 | 58 | fail msg = CouchMonad $ \conn -> do 59 | fail $ "internal error: " ++ msg 60 | 61 | instance MonadIO CouchMonad where 62 | 63 | liftIO m = CouchMonad $ \conn -> m >>= \a -> return (a,conn) 64 | 65 | makeURL :: String -- ^path 66 | -> [(String,String)] 67 | -> CouchMonad URI 68 | makeURL path query = CouchMonad $ \conn -> do 69 | return ( (ccURI conn) { uriPath = '/':path 70 | , uriQuery = '?':(urlEncodeVars query) 71 | } 72 | ,conn ) 73 | 74 | getConn :: CouchMonad (HandleStream BS.ByteString) 75 | getConn = CouchMonad $ \conn -> do 76 | r <- readIORef (ccConn conn) 77 | return (r,conn) 78 | 79 | getConnAuth :: CouchMonad (Maybe Authority) 80 | getConnAuth = CouchMonad $ \conn -> return ((ccAuth conn),conn) 81 | 82 | reopenConnection :: CouchMonad () 83 | reopenConnection = CouchMonad $ \conn -> do 84 | c <- liftIO $ readIORef (ccConn conn) >>= close 85 | connection <- liftIO $ openTCPConnection (ccHostname conn) (ccPort conn) 86 | writeIORef (ccConn conn) connection 87 | return ((), conn) 88 | 89 | makeHeaders bodyLen = 90 | [ Header HdrContentType "application/json" 91 | , Header HdrContentEncoding "UTF-8" 92 | , Header HdrConnection "keep-alive" 93 | , Header HdrContentLength (show bodyLen) 94 | ] 95 | 96 | -- |Send a request to the database. If the connection is closed, it is 97 | -- reopened and the request is resent. On other errors, we raise an 98 | -- exception. 99 | request :: String -- ^path of the request 100 | -> [(String,String)] -- ^dictionary of GET parameters 101 | -> RequestMethod 102 | -> [Header] 103 | -> String -- ^body of the request 104 | -> CouchMonad (Response String) 105 | request path query method headers body = do 106 | let body' = UTF8.fromString body 107 | url <- makeURL path query 108 | let allHeaders = (makeHeaders (BS.length body')) ++ headers 109 | conn <- getConn 110 | auth <- getConnAuth 111 | let req' = Request url method allHeaders body' 112 | let req = maybe req' (fillAuth req') auth 113 | let retry 0 = do 114 | fail $ "server error: " ++ show req 115 | retry n = do 116 | response <- liftIO $ sendHTTP conn req 117 | case response of 118 | Left err -> do 119 | reopenConnection 120 | retry (n-1) 121 | Right val -> return (unUTF8 val) 122 | retry 2 123 | where 124 | unUTF8 :: Response BS.ByteString -> Response String 125 | unUTF8 (Response c r h b) = Response c r h (UTF8.toString b) 126 | 127 | fillAuth :: Request a -> Authority -> Request a 128 | fillAuth req auth = req { rqHeaders = new : rqHeaders req } 129 | where new = Header HdrAuthorization (withAuthority auth req) 130 | 131 | runCouchDBURI :: URI -- ^URI to connect 132 | -> CouchMonad a 133 | -> IO a 134 | runCouchDBURI uri act = bracket 135 | (createCouchConnFromURI uri) 136 | closeCouchConn 137 | (flip runCouchDBWith act) 138 | 139 | runCouchDB :: String -- ^hostname 140 | -> Int -- ^port 141 | -> CouchMonad a 142 | -> IO a 143 | runCouchDB hostname port act = bracket 144 | (createCouchConn hostname port) 145 | closeCouchConn 146 | (flip runCouchDBWith act) 147 | 148 | -- |Connects to the CouchDB server at localhost:5984. 149 | runCouchDB' :: CouchMonad a -> IO a 150 | runCouchDB' = runCouchDB "127.0.0.1" 5984 151 | 152 | -- |Run a CouchDB computation with an existing CouchDB connection. 153 | runCouchDBWith :: CouchConn -> CouchMonad a -> IO a 154 | runCouchDBWith conn (CouchMonad f) = fmap fst $ f conn 155 | 156 | -- |Create a CouchDB connection for use with runCouchDBWith. 157 | createCouchConn :: String -- ^hostname 158 | -> Int -- ^port 159 | -> IO (CouchConn) 160 | createCouchConn hostname port = createCouchAuthConn hostname port Nothing 161 | 162 | -- |Create a CouchDB connection with password authentication for use 163 | -- with runCouchDBWith. 164 | createCouchAuthConn :: String -- ^hostname 165 | -> Int -- ^port 166 | -> Maybe Authority -- ^Login credentials 167 | -> IO (CouchConn) 168 | createCouchAuthConn hostname port auth = do 169 | let uriAuth = URIAuth "" hostname (':':(show port)) 170 | let baseURI = URI "http:" (Just uriAuth) "" "" "" 171 | c <- openTCPConnection hostname port 172 | conn <- newIORef c 173 | return (CouchConn conn baseURI hostname port auth) 174 | 175 | -- |Create a CouchDB from an URI connection for use with runCouchDBWith. 176 | createCouchConnFromURI :: URI -- ^URI with possible login credentials 177 | -> IO (CouchConn) 178 | createCouchConnFromURI baseURI = do 179 | createCouchAuthConn hostname port auth 180 | where 181 | ua = fromJust $ uriAuthority baseURI 182 | hostname = uriRegName ua 183 | port = uriAuthPort (Just baseURI) ua 184 | ua2 = (fromJust.parseURIAuthority.uriToAuthorityString) baseURI 185 | auth = (Just AuthBasic) 186 | `ap` (return "") 187 | `ap` (user ua2) 188 | `ap` (password ua2) 189 | `ap` (return baseURI) 190 | 191 | -- |Closes an open CouchDB connection 192 | closeCouchConn :: CouchConn -> IO () 193 | closeCouchConn (CouchConn conn _ _ _ _ ) = readIORef conn >>= close 194 | -------------------------------------------------------------------------------- /src/Database/CouchDB/JSON.hs: -------------------------------------------------------------------------------- 1 | -- |Convenient functions for parsing JSON responses. Use these 2 | -- functions to write the 'readJSON' method of the 'JSON' class. 3 | module Database.CouchDB.JSON 4 | ( jsonString 5 | , jsonInt 6 | , jsonObject 7 | , jsonField 8 | , jsonBool 9 | , jsonIsTrue 10 | ) where 11 | 12 | import Text.JSON 13 | import Data.Ratio (numerator,denominator) 14 | 15 | jsonString :: JSValue -> Result String 16 | jsonString (JSString s) = return (fromJSString s) 17 | jsonString _ = fail "expected a string" 18 | 19 | jsonInt :: (Integral n) => JSValue -> Result n 20 | jsonInt (JSRational _ r) = case (numerator r, denominator r) of 21 | (n,1) -> return (fromIntegral n) 22 | otherwise -> fail "expected an integer; got a rational" 23 | jsonInt _ = fail "expected an integer" 24 | 25 | jsonObject :: JSValue -> Result [(String,JSValue)] 26 | jsonObject (JSObject obj) = return (fromJSObject obj) 27 | jsonObject v = fail $ "expected an object, got " ++ (show v) 28 | 29 | jsonBool :: JSValue -> Result Bool 30 | jsonBool (JSBool b) = return b 31 | jsonBool v = fail $ "expected a boolean value, got " ++ show v 32 | 33 | -- |Extract a field as a value of type 'a'. If the field does not 34 | -- exist or cannot be parsed as type 'a', fail. 35 | jsonField :: JSON a => String -> [(String,JSValue)] -> Result a 36 | jsonField field obj = case lookup field obj of 37 | Just v -> readJSON v 38 | Nothing -> fail $ "could not find the field " ++ field 39 | 40 | -- |'True' when the field is defined and is true. Otherwise, 'False'. 41 | jsonIsTrue :: String -> [(String,JSValue)] -> Result Bool 42 | jsonIsTrue field obj = case lookup field obj of 43 | Just (JSBool True) -> return True 44 | otherwise -> return False 45 | -------------------------------------------------------------------------------- /src/Database/CouchDB/Unsafe.hs: -------------------------------------------------------------------------------- 1 | -- | an unsafe interface to CouchDB. Database and document names are not 2 | -- sanitized. 3 | module Database.CouchDB.Unsafe 4 | ( 5 | -- * Databases 6 | createDB 7 | , dropDB 8 | , getAllDBs 9 | -- * Documents 10 | , newNamedDoc 11 | , newDoc 12 | , updateDoc 13 | , bulkUpdateDocs 14 | , deleteDoc 15 | , forceDeleteDoc 16 | , getDocPrim 17 | , getDocRaw 18 | , getDoc 19 | , getAndUpdateDoc 20 | , getAllDocIds 21 | , getAllDocs 22 | -- * Views 23 | -- $views 24 | , CouchView (..) 25 | , newView 26 | , queryView 27 | , queryViewKeys 28 | ) where 29 | 30 | import Database.CouchDB.HTTP 31 | import Control.Monad 32 | import Control.Monad.Trans (liftIO) 33 | import Data.Maybe (fromJust, mapMaybe, isNothing) 34 | import Text.JSON 35 | import qualified Data.List as L 36 | 37 | assertJSObject :: JSValue -> CouchMonad JSValue 38 | assertJSObject v@(JSObject _) = return v 39 | assertJSObject o = fail $ "expected a JSON object; received: " ++ encode o 40 | 41 | couchResponse :: String -> [(String,JSValue)] 42 | couchResponse respBody = case decode respBody of 43 | Error s -> error $ "couchResponse: s" 44 | Ok r -> fromJSObject r 45 | 46 | request' :: String -> RequestMethod -> CouchMonad (Response String) 47 | request' path method = request path [] method [] "" 48 | 49 | -- |Creates a new database. Throws an exception if the database already 50 | -- exists. 51 | createDB :: String -> CouchMonad () 52 | createDB name = do 53 | resp <- request' name PUT 54 | unless (rspCode resp == (2,0,1)) $ 55 | error (rspReason resp) 56 | 57 | dropDB :: String -> CouchMonad Bool -- ^False if the database does not exist 58 | dropDB name = do 59 | resp <- request' name DELETE 60 | case rspCode resp of 61 | (2,0,0) -> return True 62 | (4,0,4) -> return False 63 | otherwise -> error (rspReason resp) 64 | 65 | getAllDBs :: CouchMonad [JSString] 66 | getAllDBs = do 67 | response <- request' "_all_dbs" GET 68 | case rspCode response of 69 | (2,0,0) -> 70 | case decode (rspBody response) of 71 | Ok (JSArray dbs) -> return [db | JSString db <- dbs] 72 | otherwise -> error "Unexpected couch response" 73 | otherwise -> error (show response) 74 | 75 | newNamedDoc :: (JSON a) 76 | => String -- ^database name 77 | -> String -- ^document name 78 | -> a -- ^document body 79 | -> CouchMonad (Either String JSString) 80 | -- ^Returns 'Left' on a conflict. Returns 'Right' with the 81 | -- revision number on success. 82 | newNamedDoc dbName docName body = do 83 | obj <- assertJSObject (showJSON body) 84 | r <- request (dbName ++ "/" ++ docName) [] PUT [] (encode obj) 85 | case rspCode r of 86 | (2,0,1) -> do 87 | let result = couchResponse (rspBody r) 88 | let (JSString rev) = fromJust $ lookup "rev" result 89 | return (Right rev) 90 | (4,0,9) -> do 91 | let result = couchResponse (rspBody r) 92 | let errorObj (JSObject x) = fromJust . lookup "reason"$ fromJSObject x 93 | errorObj x = x 94 | let (JSString reason) = errorObj . fromJust $ lookup "error" result 95 | return $ Left (fromJSString reason) 96 | otherwise -> error (show r) 97 | 98 | 99 | updateDoc :: (JSON a) 100 | => String -- ^database 101 | -> (JSString,JSString) -- ^document and revision 102 | -> a -- ^ new value 103 | -> CouchMonad (Maybe (JSString,JSString)) 104 | updateDoc db (doc,rev) val = do 105 | let (JSObject obj) = showJSON val 106 | let doc' = fromJSString doc 107 | let obj' = ("_id",JSString doc):("_rev",JSString rev):(fromJSObject obj) 108 | r <- request (db ++ "/" ++ doc') [] PUT [] (encode $ toJSObject obj') 109 | case rspCode r of 110 | (2,0,1) -> do 111 | let result = couchResponse (rspBody r) 112 | let (JSString rev) = fromJust $ lookup "rev" result 113 | return $ Just (doc,rev) 114 | (4,0,9) -> return Nothing 115 | otherwise -> 116 | error $ "updateDoc error.\n" ++ (show r) ++ rspBody r 117 | 118 | bulkUpdateDocs :: (JSON a) 119 | => String -- ^database 120 | -> [a] -- ^ all docs 121 | -> CouchMonad (Maybe [Either JSString (JSString, JSString)]) -- ^ error or (id,rev) 122 | bulkUpdateDocs db docs = do 123 | let obj = [("docs", docs)] 124 | r <- request (db ++ "/_bulk_docs") [] POST [] (encode $ toJSObject obj) 125 | case rspCode r of 126 | (2,0,1) -> do 127 | let Ok results = decode (rspBody r) 128 | return $ Just $ 129 | map (\result -> 130 | case (lookup "id" result, 131 | lookup "rev" result) of 132 | (Just id, Just rev) -> Right (id, rev) 133 | _ -> Left $ fromJust $ lookup "error" result 134 | ) results 135 | (4,0,9) -> return Nothing 136 | otherwise -> 137 | error $ "updateDoc error.\n" ++ (show r) ++ rspBody r 138 | 139 | 140 | -- |Delete a doc by document identifier (revision number not needed). This 141 | -- operation first retreives the document to get its revision number. It fails 142 | -- if the document doesn't exist or there is a conflict. 143 | forceDeleteDoc :: String -- ^ database 144 | -> String -- ^ document identifier 145 | -> CouchMonad Bool 146 | forceDeleteDoc db doc = do 147 | r <- getDocPrim db doc 148 | case r of 149 | Just (id,rev,_) -> deleteDoc db (id,rev) 150 | Nothing -> return False 151 | 152 | deleteDoc :: String -- ^database 153 | -> (JSString,JSString) -- ^document and revision 154 | -> CouchMonad Bool 155 | deleteDoc db (doc,rev) = do 156 | r <- request (db ++ "/" ++ (fromJSString doc)) [("rev",fromJSString rev)] 157 | DELETE [] "" 158 | case rspCode r of 159 | (2,0,0) -> return True 160 | -- TODO: figure out which error codes are normal (delete conflicts) 161 | otherwise -> fail $ "deleteDoc failed: " ++ (show r) 162 | 163 | 164 | newDoc :: (JSON a) 165 | => String -- ^database name 166 | -> a -- ^document body 167 | -> CouchMonad (JSString,JSString) -- ^ id and rev of new document 168 | newDoc db doc = do 169 | obj <- assertJSObject (showJSON doc) 170 | r <- request db [] POST [] (encode obj) 171 | case rspCode r of 172 | (2,0,1) -> do 173 | let result = couchResponse (rspBody r) 174 | let (JSString rev) = fromJust $ lookup "rev" result 175 | let (JSString id) = fromJust $ lookup "id" result 176 | return (id,rev) 177 | otherwise -> error (show r) 178 | 179 | getDoc :: (JSON a) 180 | => String -- ^database name 181 | -> String -- ^document name 182 | -> CouchMonad (Maybe (JSString,JSString,a)) -- ^'Nothing' if the 183 | -- doc does not exist 184 | getDoc dbName docName = do 185 | r <- request' (dbName ++ "/" ++ docName) GET 186 | case rspCode r of 187 | (2,0,0) -> do 188 | let result = couchResponse (rspBody r) 189 | let (JSString rev) = fromJust $ lookup "_rev" result 190 | let (JSString id) = fromJust $ lookup "_id" result 191 | case readJSON (JSObject $ toJSObject result) of 192 | Ok val -> return $ Just (id, rev, val) 193 | val -> fail $ "error parsing: " ++ encode (toJSObject result) 194 | (4,0,4) -> return Nothing -- doc does not exist 195 | otherwise -> error (show r) 196 | 197 | -- |Gets a document as a raw JSON value. Returns the document id, 198 | -- revision and value as a 'JSObject'. These fields are queried lazily, 199 | -- and may fail later if the response from the server is malformed. 200 | getDocPrim :: String -- ^database name 201 | -> String -- ^document name 202 | -> CouchMonad (Maybe (JSString,JSString,[(String,JSValue)])) 203 | -- ^'Nothing' if the document does not exist. 204 | getDocPrim db doc = do 205 | r <- request' (db ++ "/" ++ doc) GET 206 | case rspCode r of 207 | (2,0,0) -> do 208 | let obj = couchResponse (rspBody r) 209 | let ~(JSString rev) = fromJust $ lookup "_rev" obj 210 | let ~(JSString id) = fromJust $ lookup "_id" obj 211 | return $ Just (id,rev,obj) 212 | (4,0,4) -> return Nothing -- doc does not exist 213 | code -> fail $ "getDocPrim: " ++ show code ++ " error" 214 | 215 | -- |Gets a document as a Maybe String. Returns the raw result of what 216 | -- couchdb returns. Returns Nothing if the doc does not exist. 217 | getDocRaw :: String -> String -> CouchMonad (Maybe String) 218 | getDocRaw db doc = do 219 | r <- request' (db ++ "/" ++ doc) GET 220 | case rspCode r of 221 | (2,0,0) -> do 222 | return $ Just (rspBody r) 223 | (4,0,4) -> return Nothing -- doc does not exist 224 | code -> fail $ "getDocRaw: " ++ show code ++ " error" 225 | 226 | 227 | 228 | getAndUpdateDoc :: (JSON a) 229 | => String -- ^database 230 | -> String -- ^document name 231 | -> (a -> IO a) -- ^update function 232 | -> CouchMonad (Maybe String) -- ^If the update succeeds, 233 | -- return the revision number 234 | -- of the result. 235 | getAndUpdateDoc db docId fn = do 236 | r <- getDoc db docId 237 | case r of 238 | Just (id,rev,val) -> do 239 | val' <- liftIO (fn val) 240 | r <- updateDoc db (id,rev) val' 241 | case r of 242 | Just (id,rev) -> return (Just $ fromJSString rev) 243 | Nothing -> return Nothing 244 | Nothing -> return Nothing 245 | 246 | 247 | allDocRow :: JSValue -> Maybe JSString 248 | allDocRow (JSObject row) = case lookup "key" (fromJSObject row) of 249 | Just (JSString s) -> let key = fromJSString s 250 | in case key of 251 | '_':_ -> Nothing 252 | otherwise -> Just s 253 | Just _ -> error $ "key not a string in row " ++ show row 254 | Nothing -> error $ "no key in a row " ++ show row 255 | allDocRow v = error $ "expected row to be an object, received " ++ show v 256 | 257 | getAllDocIds ::String -- ^database name 258 | -> CouchMonad [JSString] 259 | getAllDocIds db = do 260 | response <- request' (db ++ "/_all_docs") GET 261 | case rspCode response of 262 | (2,0,0) -> do 263 | let result = couchResponse (rspBody response) 264 | let (JSArray rows) = fromJust $ lookup "rows" result 265 | return $ mapMaybe allDocRow rows 266 | otherwise -> error (show response) 267 | 268 | -- 269 | -- $views 270 | -- Creating and querying views 271 | -- 272 | 273 | data CouchView = ViewMap String String 274 | | ViewMapReduce String String String 275 | 276 | couchViewToJSON :: CouchView -> (String,JSValue) 277 | couchViewToJSON (ViewMap name fn) = (name,JSObject $ toJSObject fn') where 278 | fn' = [("map", JSString $ toJSString fn)] 279 | couchViewToJSON (ViewMapReduce name m r) = 280 | (name, JSObject $ toJSObject obj) where 281 | obj = [("map", JSString $ toJSString m), 282 | ("reduce", JSString $ toJSString r)] 283 | 284 | newView :: String -- ^database name 285 | -> String -- ^view set name 286 | -> [CouchView] -- ^views 287 | -> CouchMonad () 288 | newView dbName viewName views = do 289 | let content = map couchViewToJSON views 290 | body = toJSObject 291 | [("language", JSString $ toJSString "javascript"), 292 | ("views", JSObject $ toJSObject content)] 293 | path = "_design/" ++ viewName 294 | result <- newNamedDoc dbName path 295 | (JSObject body) 296 | case result of 297 | Right _ -> return () 298 | Left err -> do 299 | let update x = return . toJSObject . map replace $ fromJSObject x 300 | replace ("views", JSObject v) = 301 | ("views", JSObject . toJSObject . unite $ fromJSObject v) 302 | replace x = x 303 | unite x = L.nubBy (\(k1, _) (k2, _) -> k1 == k2) $ content ++ x 304 | res <- getAndUpdateDoc dbName path update 305 | when (isNothing res) (error "newView: creation of the view failed") 306 | 307 | toRow :: JSON a => JSValue -> (JSString,a) 308 | toRow (JSObject objVal) = (key,value) where 309 | obj = fromJSObject objVal 310 | key = case lookup "id" obj of 311 | Just (JSString s) -> s 312 | Just v -> error $ "toRow: expected id to be a string, got " ++ show v 313 | Nothing -> error $ "toRow: row does not have an id field in " 314 | ++ show obj 315 | value = case lookup "value" obj of 316 | Just v -> case readJSON v of 317 | Ok v' -> v' 318 | Error s -> error s 319 | Nothing -> error $ "toRow: row does not have a value in " ++ show obj 320 | toRow val = 321 | error $ "toRow: expected row to be an object, received " ++ show val 322 | 323 | 324 | getAllDocs :: JSON a 325 | => String -- ^databse 326 | -> [(String, JSValue)] -- ^query parameters 327 | -- |Returns a list of rows. Each row is a key, value pair. 328 | -> CouchMonad [(JSString, a)] 329 | getAllDocs db args = do 330 | let args' = map (\(k,v) -> (k,encode v)) args 331 | let url' = concat [db, "/_all_docs"] 332 | r <- request url' args' GET [] "" 333 | case rspCode r of 334 | (2,0,0) -> do 335 | let result = couchResponse (rspBody r) 336 | let (JSArray rows) = fromJust $ lookup "rows" result 337 | return $ map toRowDoc rows 338 | otherwise -> error $ "getAllDocs: " ++ show r 339 | 340 | 341 | toRowDoc :: JSON a => JSValue -> (JSString,a) 342 | toRowDoc (JSObject objVal) = (key,value) where 343 | obj = fromJSObject objVal 344 | key = case lookup "id" obj of 345 | Just (JSString s) -> s 346 | Just v -> error $ "toRowDoc: expected id to be a string, got " ++ show v 347 | Nothing -> error $ "toRowDoc: row does not have an id field in " 348 | ++ show obj 349 | value = case lookup "doc" obj of 350 | Just v -> case readJSON v of 351 | Ok v' -> v' 352 | Error s -> error s 353 | Nothing -> error $ "toRowDoc: row does not have a value in " ++ show obj 354 | toRowDoc val = 355 | error $ "toRowDoc: expected row to be an object, received " ++ show val 356 | 357 | 358 | queryView :: (JSON a) 359 | => String -- ^database 360 | -> String -- ^design 361 | -> String -- ^view 362 | -> [(String, JSValue)] -- ^query parameters 363 | -- |Returns a list of rows. Each row is a key, value pair. 364 | -> CouchMonad [(JSString, a)] 365 | queryView db viewSet view args = do 366 | let args' = map (\(k,v) -> (k,encode v)) args 367 | let url' = concat [db, "/_design/", viewSet, "/_view/", view] 368 | r <- request url' args' GET [] "" 369 | case rspCode r of 370 | (2,0,0) -> do 371 | let result = couchResponse (rspBody r) 372 | let (JSArray rows) = fromJust $ lookup "rows" result 373 | return $ map toRow rows 374 | otherwise -> error (show r) 375 | 376 | -- |Like 'queryView', but only returns the keys. Use this for key-only 377 | -- views where the value is completely ignored. 378 | queryViewKeys :: String -- ^database 379 | -> String -- ^design 380 | -> String -- ^view 381 | -> [(String, JSValue)] -- ^query parameters 382 | -> CouchMonad [String] 383 | queryViewKeys db viewSet view args = do 384 | let args' = map (\(k,v) -> (k,encode v)) args 385 | let url' = concat [db, "/_design/", viewSet, "/_view/", view] 386 | r <- request url' args' GET [] "" 387 | case rspCode r of 388 | (2,0,0) -> do 389 | let result = couchResponse (rspBody r) 390 | case lookup "rows" result of 391 | Just (JSArray rows) -> liftIO $ mapM rowKey rows 392 | otherwise -> fail $ "queryView: expected rows" 393 | otherwise -> error (show r) 394 | 395 | rowKey :: JSValue -> IO String 396 | rowKey (JSObject obj) = do 397 | let assoc = fromJSObject obj 398 | case lookup "id" assoc of 399 | Just (JSString s) -> return (fromJSString s) 400 | v -> fail "expected id" 401 | rowKey v = fail "expected id" 402 | -------------------------------------------------------------------------------- /src/Tests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad.Trans (liftIO) 4 | import Control.Exception (finally) 5 | import Test.HUnit 6 | import Database.CouchDB 7 | import Database.CouchDB.JSON 8 | import Text.JSON 9 | import System.Exit 10 | import Control.Monad 11 | 12 | -- ---------------------------------------------------------------------------- 13 | -- Helper functions 14 | -- 15 | 16 | assertDBEqual :: (Eq a, Show a) => String -> a -> CouchMonad a -> Assertion 17 | assertDBEqual msg v m = do 18 | v' <- runCouchDB' m 19 | assertEqual msg v' v 20 | 21 | instance Assertable (Either String a) where 22 | assert (Left s) = assertFailure s 23 | assert (Right _) = return () 24 | 25 | assertRight :: (Either String a) -> IO a 26 | assertRight (Left s) = assertFailure s >> fail "assertion failed" 27 | assertRight (Right a) = return a 28 | 29 | instance Assertable (Maybe a) where 30 | assert Nothing = assertFailure "expected (Just ...), got Nothing" 31 | assert (Just a) = return () 32 | 33 | assertJust :: Maybe a -> IO a 34 | assertJust (Just v) = return v 35 | assertJust Nothing = do 36 | assertFailure "expected (Just ...), got Nothing" 37 | fail "assertion failed" 38 | 39 | testWithDB :: String -> (DB -> CouchMonad Bool) -> Test 40 | testWithDB testDescription testCase = 41 | TestLabel testDescription $ TestCase $ do 42 | let action = runCouchDB' $ do 43 | createDB "haskellcouchdbtest" 44 | result <- testCase (db "haskellcouchdbtest") 45 | liftIO $ assertBool testDescription result 46 | let teardown = runCouchDB' (dropDB "haskellcouchdbtest") 47 | let failure _ = assertFailure (testDescription ++ "; exception signalled") 48 | action `catch` failure `finally` teardown 49 | 50 | main = do 51 | putStrLn "Running CouchDB test suite..." 52 | results <- runTestTT allTests 53 | when (errors results > 0 || failures results > 0) 54 | exitFailure 55 | putStrLn "Testing complete." 56 | return () 57 | 58 | -- ----------------------------------------------------------------------------- 59 | -- Data definitions for testing 60 | -- 61 | 62 | data Age = Age 63 | { ageName :: String 64 | , ageValue :: Int 65 | } deriving (Eq,Show) 66 | 67 | instance JSON Age where 68 | 69 | showJSON (Age name val) = JSObject $ toJSObject 70 | [ ("name", showJSON name) 71 | , ("age", showJSON val) 72 | ] 73 | 74 | readJSON val = do 75 | obj <- jsonObject val 76 | name <- jsonField "name" obj 77 | age <- jsonField "age" obj 78 | return (Age name age) 79 | 80 | -- ---------------------------------------------------------------------------- 81 | -- Test cases 82 | -- 83 | 84 | 85 | testCreate = TestCase $ assertDBEqual "create/drop database" True $ do 86 | createDB "test1" 87 | dropDB "test1" -- returns True since the database exists. 88 | 89 | people = [ Age "Arjun" 18, Age "Alex" 17 ] 90 | 91 | testNamedDocs = testWithDB "add named documents" $ \mydb -> do 92 | newNamedDoc mydb (doc "arjun") (people !! 0) 93 | newNamedDoc mydb (doc "alex") (people !! 1) 94 | Just (_,_,v1) <- getDoc mydb (doc "arjun") 95 | Just (_,_,v2) <- getDoc mydb (doc "alex") 96 | return $ (v1 == people !! 0) && (v2 == people !! 1) 97 | 98 | testUTF8 = testWithDB "test UTF8 characters" $ \db -> do 99 | newNamedDoc db (doc "d0") (Age "äöüß" 900) 100 | Just (_, _, d) <- getDoc db (doc "d0") 101 | return (ageName d == "äöüß") 102 | 103 | 104 | allTests = TestList [ testCreate, testNamedDocs, testUTF8 ] 105 | 106 | --------------------------------------------------------------------------------