couchdb-enumerator 0.3.4 → 0.3.5
raw patch · 10 files changed
+1287/−751 lines, 10 filesdep +couchdb-enumeratordep −containersdep ~HUnitdep ~QuickCheckdep ~aesonPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: couchdb-enumerator
Dependencies removed: containers
Dependency ranges changed: HUnit, QuickCheck, aeson, lifted-base, test-framework
API changes (from Hackage documentation)
- Database.CouchDB.Enumerator: instance MonadIO m => MonadCouch (ReaderT CouchConnection m)
+ Database.CouchDB.Enumerator: couch' :: MonadCouch m => Method -> Path -> RequestHeaders -> Query -> (ResponseHeaders -> Iteratee ByteString m a) -> RequestBody m -> Iteratee ByteString m a
+ Database.CouchDB.Enumerator: couchDeleteDb :: MonadCouch m => Path -> m ()
+ Database.CouchDB.Enumerator: couchPutDb :: MonadCouch m => Path -> m ()
+ Database.CouchDB.Enumerator: couchPutRev :: (MonadCouch m, ToJSON a) => Path -> Revision -> Query -> a -> m Revision
+ Database.CouchDB.Enumerator: couchRev :: MonadCouch m => Path -> m Revision
+ Database.CouchDB.Enumerator: instance (MonadIO m, MonadBaseControl IO m) => MonadCouch (ReaderT CouchConnection m)
+ Database.CouchDB.Enumerator.Generic: CouchDoc :: Path -> Revision -> a -> CouchDoc a
+ Database.CouchDB.Enumerator.Generic: consumeView :: (MonadCouch m, Data a) => Path -> Query -> m [a]
+ Database.CouchDB.Enumerator.Generic: couchGet :: (MonadCouch m, Data a) => Path -> Query -> m (CouchDoc a)
+ Database.CouchDB.Enumerator.Generic: couchPut :: (MonadCouch m, Data a) => Path -> Revision -> Query -> a -> m Revision
+ Database.CouchDB.Enumerator.Generic: couchPut' :: (MonadCouch m, Data a) => Path -> Query -> a -> m Revision
+ Database.CouchDB.Enumerator.Generic: data CouchDoc a
+ Database.CouchDB.Enumerator.Generic: instance FromJSON DocSig
+ Database.CouchDB.Enumerator.Generic: instance Show a => Show (CouchDoc a)
+ Database.CouchDB.Enumerator.Generic: parseGeneric :: (Monad m, Data a) => Enumeratee Object a m b
- Database.CouchDB.Enumerator: class MonadIO m => MonadCouch m
+ Database.CouchDB.Enumerator: class (MonadIO m, MonadBaseControl IO m) => MonadCouch m
Files
- Database/CouchDB/Enumerator.hs +0/−403
- couchdb-enumerator.cabal +86/−80
- src/Database/CouchDB/Enumerator.hs +572/−0
- src/Database/CouchDB/Enumerator/Generic.hs +155/−0
- test/Database/CouchDB/Enumerator/Test/Basic.hs +114/−0
- test/Database/CouchDB/Enumerator/Test/Generic.hs +87/−0
- test/Database/CouchDB/Enumerator/Test/Util.hs +135/−0
- test/Database/CouchDB/Enumerator/Test/View.hs +118/−0
- test/Main.hs +20/−0
- tests.hs +0/−268
− Database/CouchDB/Enumerator.hs
@@ -1,403 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, OverloadedStrings, FlexibleInstances, FlexibleContexts #-}---- | This module is a very thin wrapper around "Network.HTTP.Enumerator" using the aeson package to parse--- and encode JSON. The Couch DB HTTP API is the best place to learn about how to use this library.--- <http://wiki.apache.org/couchdb/Complete_HTTP_API_Reference>------ > {-# LANGUAGE OverloadedStrings #-}--- > import Control.Monad.IO.Class (liftIO)--- > import Data.Aeson--- > import qualified Data.ByteString.Lazy as BL--- > import Data.ByteString.UTF8 (fromString)--- > import Data.Enumerator (($$), run_)--- > import qualified Data.Enumerator.List as EL--- > import Database.CouchDB.Enumerator--- >--- > testCouch :: IO ()--- > testCouch = runCouch "localhost" 5984 "test" $ do--- > --- > -- Insert some documents. Note that the dbname passed to withCouchConnection--- > -- is prepended to the given path, so this is a put to--- > -- http://localhost:5984/test/doc1--- > rev1 <- couchPut "doc1" [] $ object [ "foo" .= (3 :: Int), "bar" .= ("abc" :: String) ]--- > rev2 <- couchPut "doc2" [] $ object [ "foo" .= (7 :: Int), "baz" .= (145 :: Int) ]--- >--- > -- Load the document and print it out--- > couchGet "doc1" [] >>= liftIO . BL.putStrLn . encode . Object--- >--- > -- Overwite the document. We supply the revision, otherwise Couch DB would give an error.--- > -- (The revision could also have been passed in the query arguments.)--- > rev3 <- couchPut "doc1" [] $ object [ "foo" .= (10 :: Int)--- > , "bar" .= ("def" :: String)--- > , "_rev" .= rev1 --- > ]--- >--- > -- Create a view--- > couchPut_ "_design/testdesign" [] $ --- > object [ "language" .= ("javascript" :: String)--- > , "views" .= object [ "myview" .= object [ "map" .=--- > ("function(doc) { emit(doc.foo, doc); }" :: String)--- > ]]--- > ]--- >--- > -- Read from the view using couchGet and print it out.--- > couchGet "_design/testdesign/_view/myview" [] >>= liftIO . BL.putStrLn . encode . Object--- > couchGet "_design/testdesign/_view/myview" [(fromString "key", Just $ fromString "10")]--- > >>= liftIO . BL.putStrLn . encode . Object--- >--- > -- Read the view using couchView and print it out.--- > run_ $ couchView "testdesign/_view/myview" [] $$--- > EL.foldM (\_ o -> liftIO $ BL.putStrLn $ encode $ Object o) ()--- > run_ $ couchView "testdesign/_view/myview" [(fromString "key", Just $ fromString "10")] $$--- > EL.foldM (\_ o -> liftIO $ BL.putStrLn $ encode $ Object o) ()--- >--- > -- Delete the objects--- > couchDelete "doc1" rev3--- > couchDelete "doc2" rev2-module Database.CouchDB.Enumerator(- -- * Couch DB Connection- CouchConnection(..)- , runCouch- , withCouchConnection- , CouchError(..)- , MonadCouch(..)-- -- * Accessing Couch DB- , Path- , Revision- , couchGet- , couchPut- , couchPut_- , couchDelete- , couchView- , extractViewValue- , couch-- -- * Connection Pooling- -- $pool-- -- * Yesod Integration- -- $yesod-) where--import Control.Applicative-import Control.Exception (Exception, throw, bracket)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (MonadTrans, lift)-import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp)-import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)-import qualified Data.Aeson as A-import qualified Data.Aeson.Encode as AE-import Data.Attoparsec-import Data.Attoparsec.Enumerator (iterParser)-import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as BU8-import Data.Enumerator hiding (map)-import qualified Data.HashMap.Lazy as M-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Data.Typeable (Typeable)-import qualified Network.HTTP.Enumerator as H-import qualified Network.HTTP.Types as HT---- | Represents a connection to a single Couch DB Database. ------ A connection contains a 'H.Manager' and reuses it for multiple requests, which means a --- single open HTTP connection to CouchDB will be kept around until the manager is closed--- (http-enumerator will create more connections if needed, it just keeps only one and--- closes the rest.) See the Pool section for more information.-data CouchConnection = CouchConnection {- host :: B.ByteString- , port :: Int- , manager :: H.Manager- , dbname :: String-}---- | Connect to a CouchDB database, call the supplied function, and then close the connection.--- --- If you create your own instance of 'MonadCouch' instead of using 'runCouch', this function--- will help you create the 'CouchConnection'. On the other hand, if you want to implement--- connection pooling, you will not be able to use withCouchConnection and must create the--- connection yourself.-withCouchConnection :: (MonadBaseControl IO m) => String -- ^ host- -> Int -- ^ port- -> String -- ^ database name- -> (CouchConnection -> m a) -- ^ function to run- -> m a-withCouchConnection h p db f = liftBaseOp (bracket H.newManager H.closeManager) go- where go m = f $ CouchConnection (BU8.fromString h) p m db---- | A Couch DB Error. If the error comes from http, the http status code is also given. Non-http errors--- include things like errors parsing the response.-data CouchError = CouchError (Maybe Int) String- deriving (Show,Typeable)-instance Exception CouchError---- | A monad which allows access to the connection.-class MonadIO m => MonadCouch m where- couchConnection :: m CouchConnection--instance (MonadIO m) => MonadCouch (ReaderT CouchConnection m) where- couchConnection = ask---- | Run a sequence of CouchDB actions.------ The functions below to access CouchDB require a 'MonadCouch' instance to access the connection--- information. 'ReaderT' is an instance of 'MonadCouch', and /runCouch/ runs a sequence of database--- actions using 'ReaderT'. See the top of this page for an example using /runCouch/.------ The main reason to not use /runCouch/ is to obtain more control over connection pooling.--- Also, if your db code is part of a larger monad, it makes sense to just make the larger monad--- an instance of 'MonadCouch' and skip the intermediate ReaderT, since then performance is--- improved by eliminating one monad from the final transformer stack.------ This function is a combination of 'withCouchConnection' and 'runReaderT'-runCouch :: (MonadIO m, MonadBaseControl IO m) => String -- ^ host- -> Int -- ^ port- -> String -- ^ database name- -> ReaderT CouchConnection m a -- ^ CouchDB actions- -> m a-runCouch h p d = withCouchConnection h p d . runReaderT---- | A path to a Couch DB Object.-type Path = String---- | Represents a revision of a Couch DB Document.-type Revision = T.Text---- | The most general method of accessing CouchDB. This is a very thin wrapper around 'H.http'. Most of the--- time you should use one of the other access functions, but this function is needed for example to write--- and read attachments that are not in JSON format.-couch :: MonadCouch m- => HT.Method -- ^ Method- -> Path -- ^ The dbname from the connection is prepended to- -- this path.- -> HT.Query -- ^ Query arguments- -> Iteratee B.ByteString m a -- ^ Iteratee to process the response if no error occurs.- -> H.RequestBody m -- ^ Body- -> Iteratee B.ByteString m a-couch m p q i b = Iteratee $ do- conn <- couchConnection- let req = H.def { H.method = m- , H.host = host conn- , H.port = port conn- , H.path = BU8.fromString ("/" ++ dbname conn ++ "/" ++ p)- , H.queryString = q- , H.requestBody = b- }- runIteratee $ H.http req (\s _ -> checkStatus s i) (manager conn)---- | Load a single object from couch DB.-couchGet :: MonadCouch m- => Path -- ^ the dbname is prepended to this string to form the full path.- -> HT.Query -- ^ Query arguments.- -> m A.Object-couchGet p q = do v <- run_ $ couch HT.methodGet p q (iterParser A.json) (H.RequestBodyBS B.empty)- either throw return $ valToObj v---- | Put an object in Couch DB, returning the new Revision.-couchPut :: (MonadCouch m, A.ToJSON a) - => Path -- ^ the dbname is prepended to this string to form the full path.- -> HT.Query -- ^ Query arguments.- -> a -- ^ The object to store.- -> m Revision-couchPut p q val = do v <- run_ $ couch HT.methodPut p q (iterParser A.json) body- either (liftIO . throw) return (valToObj v >>= objToRev)- where body = jsonToReqBody val---- | A version of 'couchPut' which ignores the return value. This is slightly faster than / _ <- couchPut .../--- since the JSON parser is not run.-couchPut_ :: (MonadCouch m, A.ToJSON a) - => Path -- ^ the dbname is prepended to this string to form the full path.- -> HT.Query -- ^ Query arguments.- -> a -- ^ The object to store.- -> m ()-couchPut_ p q val = run_ $ couch HT.methodPut p q (yield () EOF) body- where body = jsonToReqBody val---- | Delete the given revision of the object.-couchDelete :: MonadCouch m- => Path -- ^ the dbname is prepended to this string to form the full path. - -> Revision- -> m ()-couchDelete p r = run_ $ couch HT.methodDelete p [("rev", Just $ TE.encodeUtf8 r)]- (yield () EOF) (H.RequestBodyBS B.empty)---- | Load from a Couch DB View.------ While you can use 'couchGet' on a view object, this function combines the--- incredible power of http-enumerator and attoparsec to allow you to process objects in constant space.--- As data is read from the network, it is fed into attoparsec. When attoparsec completes parsing an object--- it is sent out the enumerator.------ The objects enumerated are the entries in the \"rows\" property of the view result, which--- means they are not directly the objects you put into the database. See <http://wiki.apache.org/couchdb/HTTP_view_API>--- for more information. The objects inserted into the database are available in the \"value\" entry, and can be extracted--- with the 'extractViewValue' enumeratee, for example:------ > couchView "mydesigndoc/_view/myview" [(fromString "key", Just $ fromString "3")] $= extractViewValue-couchView :: MonadCouch m- => Path -- ^ \/dbname\/_design\/ is prepended to the given path- -> HT.Query -- ^ Query arguments.- -> Enumerator A.Object m a-couchView p q step = do s <- lift $ run $ couch HT.methodGet ("_design/" ++ p) q (parseView step) (H.RequestBodyBS B.empty)- either throwError returnI s----- | An enumeratee to extract the \"value\" member of JSON objects.------ This is useful to extract the object from the data returned from a view. For example, Couch DB will return--- objects that look like the following:------ > { "id":"64ACF01B05F53ACFEC48C062A5D01D89", "key":null, "value": { some object } }------ and this enumeratee will extract /{some object}/-extractViewValue :: Monad m => Enumeratee A.Object A.Object m a-extractViewValue = mapEither f- where f v = case M.lookup "value" v of- (Just (A.Object o)) -> Right o- _ -> Left $ CouchError Nothing "view does not contain value"----------------------------------------------------------------------------------------------- Helper Code---------------------------------------------------------------------------------------------- | Converts a json object into a 'H.RequestBodyEnumChunked'-jsonToReqBody :: (A.ToJSON a, Monad m) => a -> H.RequestBody m-jsonToReqBody val = H.RequestBodyEnumChunked enum- where jbuilder = AE.fromValue $ A.toJSON val- enum (Continue k) = k (Chunks [jbuilder])- enum step = returnI step---- | Check status codes from couch db.-checkStatus :: Monad m => HT.Status -> Iteratee B.ByteString m b - -> Iteratee B.ByteString m b-checkStatus (HT.Status 200 _) i = i-checkStatus (HT.Status 201 _) i = i-checkStatus (HT.Status 202 _) i = i-checkStatus (HT.Status 304 _) i = i-checkStatus (HT.Status c m) _ = iterParser A.json >>= \v -> throwError $ CouchError (Just c) $ msg v- where msg v = BU8.toString m ++ reason v- reason (A.Object v) = case M.lookup "reason" v of- Just (A.String t) -> ": " ++ T.unpack t- _ -> ""- reason _ = []---- | Convers a value to an object-valToObj :: A.Value -> Either CouchError A.Object-valToObj (A.Object o) = Right o-valToObj _ = Left $ CouchError Nothing "Couch DB did not return an object"---- | Converts an object to a revision-objToRev :: A.Object -> Either CouchError Revision-objToRev o = case M.lookup "rev" o of- (Just (A.String r)) -> Right r- _ -> Left $ CouchError Nothing "unable to find revision" --data CommaOrCloseBracket = Comma | CloseBracket--commaOrClose :: Parser CommaOrCloseBracket-commaOrClose = do- skipWhile (\c -> c /= 44 && c /= 93) <?> "Checking for next comma"- w <- anyWord8- if w == 44 then return Comma else return CloseBracket----- | The main loop of processing the view rows.-viewLoop :: MonadIO m => Enumeratee B.ByteString A.Object m a-viewLoop (Yield a _) = return $ Yield a EOF-viewLoop (Error err) = return $ Error err-viewLoop (Continue k) = do - v <- iterParser (A.json <?> "json object")-- vobj <- case v of- (A.Object o) -> return o- _ -> throwError $ CouchError Nothing "view entry is not an object"-- step' <- lift $ runIteratee $ k $ Chunks [vobj]-- res <- iterParser (commaOrClose <?> "comma or close")- case res of- Comma -> viewLoop step'- CloseBracket -> case step' of- (Continue k') -> lift $ runIteratee $ k' EOF- _ -> return step'--viewStart :: Parser Bool-viewStart = do _ <- string "{\"total_rows\":"- skipWhile (\x -> x >= 48 && x <= 57)- _ <- string ",\"offset\":"- skipWhile (\x -> x >= 48 && x <= 57)- _ <- string ",\"rows\":["- (string "]}" >> return False) <|> return True---- | Enumeratee to parse the data returned by a view.-parseView :: MonadIO m => Enumeratee B.ByteString A.Object m a-parseView (Yield a _) = return $ Yield a EOF-parseView (Error err) = return $ Error err-parseView (Continue k) = do b <- iterParser (viewStart <?> "start of view") - if b- then viewLoop $ Continue k- else lift $ runIteratee $ k EOF---mapEither :: (Exception e, Monad m) => (a -> Either e b) -> Enumeratee a b m c-mapEither f = checkDone (continue . step) where- step k EOF = yield (Continue k) EOF- step k (Chunks xs) = case Prelude.mapM f xs of- Left err -> throwError err- Right xs' -> k (Chunks xs') >>== mapEither f---- $pool--- The 'H.Manager' stored in the CouchConnection maintains a pool of open connections in an IORef,--- but keeps a maximum of one open connection per (host,port) pair. Also, each time 'runCouch' or--- 'withCouchConnection' is called, a new manager (and thus new connections) is created and destroyed.------ For more precise control over pooling, use the --- <http://hackage.haskell.org/package/resource-pool> or--- <http://hackage.haskell.org/package/pool> packages combined with the--- 'H.newManager' and 'H.closeManager' functions.------ For example, the following code using the resource-pool package runs a /ReaderT CouchConnection m/ action using a--- HTTP connection from a pool.--- --- > runPooledCouch :: MonadCatchIO m--- > => Pool Manager -> String -> Int -> String -> ReaderT CouchConnection m a -> m a--- > runPooledCouch p host port dbname c = withResource p $ \m -> do--- > runReaderT c $ CouchConnection (BU8.fromString host) port m dbname---- $yesod--- Integrating couchdb-enumerator with yesod looks something the way the scaffold sets up the--- YesodPersist instance.------ > data MyFoundation = MyFoundation --- > { ... (normal yesod stuff in the foundation type)--- > , connPool :: Data.Pool.Pool H.Manager--- > , dbLocation :: B.ByteString--- > , databaseName :: String--- > }--- >--- > newtype CouchDBPersist m a = CouchDBPersist { unCouchDBPersist :: ReaderT CouchConnection m a }--- > deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadTransControl,--- > MonadBaseControl, MonadPlus, MonadCouch)--- >--- > instance YesodPersist MyFoundation where--- > type YesodPersistBackend = CouchDBPersist--- > runDB r = do pool <- connPool <$> getYesod--- > loc <- dbLocation <$> getYesod--- > db <- databaseName <$> getYesod--- > Data.Pool.withPool' pool $ \m ->--- > runReaderT (unCouchDBPersist r) $ CouchConnection loc 5984 m db------ Then you can write handler code as follows:------ > getFooR :: PersonID -> Handler RepPlain--- > getFooR p = do--- > person <- runDB $ couchGet p []--- > return $ RepPlain $ toContent $ Aeson.encode $ maybe Aeson.null person------ Alternatively, you don't need to make your Foundation an instance of YesodPersist, you could--- supply your own runCouchDB function which is just a version of runDB specialized to your foundation--- and just use that from the handlers.---- vim: set expandtab:set tabstop=4:
couchdb-enumerator.cabal view
@@ -1,80 +1,86 @@-Name: couchdb-enumerator-Version: 0.3.4-Cabal-Version: >= 1.8-License: BSD3-License-File: LICENSE-Author: John Lenz <lenz@math.uic.edu>-Maintainer: John Lenz <lenz@math.uic.edu>-Synopsis: Couch DB client library using http-enumerator and aeson-Category: Database, Web-Description:- This package is a thin wrapper around http-enumerator to access a Couch DB Database,- using the aeson package to parse and encode JSON data. http-enumerator, aeson, and- attoparsec fit togther so well that this package is mostly just a direct combination- of these packages. The single additional feature in this package is an attoparsec parser- for views, which allows constant memory processing of view returns.--Build-Type: Simple-Stability: Experimental-Homepage: http://bitbucket.org/wuzzeb/couchdb-enumerator--flag test- description: Build the test executable.- default: False--source-repository head- type: mercurial- location: https://bitbucket.org/wuzzeb/couchdb-enumerator--Library- ghc-options: -Wall -fwarn-tabs-- Exposed-Modules:- Database.CouchDB.Enumerator-- Build-Depends:- aeson >= 0.4 && < 0.5- , attoparsec >= 0.8 && < 0.11- , attoparsec-enumerator >= 0.2 && < 0.4- , base >= 4 && < 5- , bytestring >= 0.9 && < 0.10- , enumerator >= 0.4 && < 0.5- , http-types >= 0.6 && < 0.7- , http-enumerator >= 0.7 && < 0.8- , monad-control >= 0.3 && < 0.4- , text >= 0.11 && < 0.12- , transformers >= 0.2 && < 0.3- , unordered-containers >= 0.1 && < 0.2- , utf8-string >= 0.3 && < 0.4--Executable test-couch- ghc-options: -Wall -fwarn-tabs -rtsopts- main-is: tests.hs- if flag(test)- Buildable: True- Build-Depends:- aeson >= 0.4 && < 0.5- , attoparsec >= 0.8 && < 0.11- , attoparsec-enumerator >= 0.2 && < 0.4- , base >= 4 && < 5- , bytestring >= 0.9 && < 0.10- , enumerator >= 0.4 && < 0.5- , http-types >= 0.6 && < 0.7- , http-enumerator >= 0.7 && < 0.8- , monad-control >= 0.3 && < 0.4- , text >= 0.11 && < 0.12- , transformers >= 0.2 && < 0.3- , unordered-containers >= 0.1 && < 0.2- , utf8-string >= 0.3 && < 0.4-- , containers- , lifted-base- , QuickCheck >= 2- , HUnit- , test-framework- , test-framework-quickcheck2- , test-framework-hunit- , vector- else- Buildable: False-+name: couchdb-enumerator +version: 0.3.5 +cabal-version: >= 1.8 +license: BSD3 +license-file: LICENSE +author: John Lenz <lenz@math.uic.edu> +maintainer: John Lenz <lenz@math.uic.edu> +synopsis: Couch DB client library using http-enumerator and aeson +category: Database, Web +description: This package is a thin wrapper around http-enumerator to access a Couch DB Database, + using the aeson package to parse and encode JSON data. http-enumerator, aeson, and + attoparsec fit togther so well that this package is mostly just a direct combination + of these packages. The single additional feature in this package is an attoparsec parser + for views, which allows constant memory processing of view returns. +build-type: Simple +stability: Experimental +homepage: http://bitbucket.org/wuzzeb/couchdb-enumerator + +-- Temp workaround for http://hackage.haskell.org/trac/hackage/ticket/792 +extra-source-files: + test/Main.hs, + test/Database/CouchDB/Enumerator/Test/Generic.hs, + test/Database/CouchDB/Enumerator/Test/Basic.hs, + test/Database/CouchDB/Enumerator/Test/View.hs, + test/Database/CouchDB/Enumerator/Test/Util.hs + +source-repository head + type: mercurial + location: https://bitbucket.org/wuzzeb/couchdb-enumerator + +library + ghc-options: -Wall -fwarn-tabs + hs-source-dirs: src + build-depends: + base >= 4 && < 5, + aeson >= 0.5 && < 0.6, + attoparsec >= 0.8 && < 0.11, + attoparsec-enumerator >= 0.2 && < 0.4, + bytestring >= 0.9 && < 0.10, + enumerator >= 0.4 && < 0.5, + http-types >= 0.6 && < 0.7, + http-enumerator >= 0.7 && < 0.8, + lifted-base >= 0.1 && < 0.2, + monad-control >= 0.3 && < 0.4, + text >= 0.11 && < 0.12, + transformers >= 0.2 && < 0.3, + unordered-containers >= 0.1 && < 0.2, + utf8-string >= 0.3 && < 0.4 + exposed-modules: + Database.CouchDB.Enumerator, + Database.CouchDB.Enumerator.Generic + +test-suite test + type: exitcode-stdio-1.0 + x-uses-tf: true + ghc-options: -Wall -rtsopts + hs-source-dirs: test + main-is: Main.hs + build-depends: + couchdb-enumerator, + base >= 4 && < 5, + aeson >= 0.5 && < 0.6, + attoparsec >= 0.8 && < 0.11, + attoparsec-enumerator >= 0.2 && < 0.4, + bytestring >= 0.9 && < 0.10, + enumerator >= 0.4 && < 0.5, + http-types >= 0.6 && < 0.7, + http-enumerator >= 0.7 && < 0.8, + lifted-base >= 0.1 && < 0.2, + monad-control >= 0.3 && < 0.4, + text >= 0.11 && < 0.12, + transformers >= 0.2 && < 0.3, + unordered-containers >= 0.1 && < 0.2, + utf8-string >= 0.3 && < 0.4, + HUnit >= 1.2 && < 2, + QuickCheck >= 2.4, + test-framework >= 0.4.1, + test-framework-quickcheck2, + test-framework-hunit, + vector + other-modules: + Database.CouchDB.Enumerator.Test.Generic, + Database.CouchDB.Enumerator.Test.Basic, + Database.CouchDB.Enumerator.Test.View, + Database.CouchDB.Enumerator.Test.Util +
+ src/Database/CouchDB/Enumerator.hs view
@@ -0,0 +1,572 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}++{- | +This module is a very thin wrapper around "Network.HTTP.Enumerator" using +the aeson package to parse and encode JSON. The Couch DB HTTP API is the +best place to learn about how to use this library.+<http://wiki.apache.org/couchdb/Complete_HTTP_API_Reference>++> {-# LANGUAGE OverloadedStrings #-}+> import Control.Monad.IO.Class (liftIO)+> import Data.Aeson+> import qualified Data.ByteString.Lazy as BL+> import Data.ByteString.UTF8 (fromString)+> import Data.Enumerator (($$), run_)+> import qualified Data.Enumerator.List as EL+> import Database.CouchDB.Enumerator+>+> testCouch :: IO ()+> testCouch = runCouch "localhost" 5984 "test" $ do+> -- Make database if not present+> couchPutDb ""+> +> -- Insert some documents. Note that the dbname passed to +> -- withCouchConnection is prepended to the given path, so this is a put +> -- to http://localhost:5984/test/doc1+> rev1 <- couchPut "doc1" [] $ object [ "foo" .= (3 :: Int), +> "bar" .= ("abc" :: String) ]+> rev2 <- couchPut "doc2" [] $ object [ "foo" .= (7 :: Int), +> "baz" .= (145 :: Int) ]+>+> -- Load the document and print it out+> couchGet "doc1" [] >>= liftIO . BL.putStrLn . encode . Object+>+> -- Overwite the document. We supply the revision, otherwise Couch DB +> -- would give an error. (The revision could also have been passed +> -- in the query arguments.)+> rev3 <- couchPut "doc1" [] $ object [ "foo" .= (10 :: Int)+> , "bar" .= ("def" :: String)+> , "_rev" .= rev1 ]+>+> -- Create a view+> couchPut_ "_design/testdesign" [] $ +> object [ "language" .= ("javascript" :: String)+> , "views" .= object [ "myview" .= object [ "map" .=+> ("function(doc) { emit(doc.foo, doc); }" :: String)+> ]]+> ]+>+> -- Read from the view using couchGet and print it out.+> couchGet "_design/testdesign/_view/myview" [] >>= +> liftIO . BL.putStrLn . encode . Object+> couchGet "_design/testdesign/_view/myview" +> [(fromString "key", Just $ fromString "10")]+> >>= liftIO . BL.putStrLn . encode . Object+>+> -- Read the view using couchView and print it out.+> run_ $ couchView "testdesign/_view/myview" [] $$+> EL.foldM (\_ o -> liftIO $ BL.putStrLn $ encode $ Object o) ()+>+> -- .. with restrictions and extracting view value+> run_ $ couchView "testdesign/_view/myview" +> [(fromString "key", Just $ fromString "10")] $= extractViewValue $$+> EL.foldM (\_ o -> liftIO $ BL.putStrLn $ encode $ Object o) ()+>+> -- .. and in strict manner+> v1 <- couchView "testdesign/_view/myview" [] $= extractViewValue+> EL.consume+> print v1+>+> -- Delete the objects+> couchDelete "doc1" rev3+> couchDelete "doc2" rev2+>+> -- Delete test database+> couchDeleteDb ""+-}++module Database.CouchDB.Enumerator(+ -- * Couch DB Connection+ CouchConnection(..)+ , runCouch+ , withCouchConnection+ , CouchError(..)+ , MonadCouch(..)++ -- * Couch DB database API+ , couchPutDb+ , couchDeleteDb++ -- * Couch DB documents API+ , Path+ , Revision+ , couchRev+ , couchGet+ , couchPut+ , couchPutRev+ , couchPut_+ , couchDelete++ -- * Couch DB views API+ , couchView+ , extractViewValue++ -- * Low-level API+ , couch+ , couch'++ -- * Connection Pooling+ -- $pool++ -- * Yesod Integration+ -- $yesod+) where++import Prelude hiding (catch)+import Control.Applicative+import Control.Exception (Exception, throw, bracket)+import Control.Exception.Lifted (catch)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp)+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Data.Maybe (fromJust)+import qualified Data.Aeson as A+--import qualified Data.Aeson.Encode as AE+import Data.Attoparsec+import Data.Attoparsec.Enumerator (iterParser)+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as BU8+import Data.Enumerator hiding (map)+import qualified Data.HashMap.Lazy as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Typeable (Typeable)+import qualified Network.HTTP.Enumerator as H+import qualified Network.HTTP.Types as HT++-- | Represents a connection to a single Couch DB Database. +--+-- A connection contains a 'H.Manager' and reuses it for multiple requests, +-- which means a single open HTTP connection to CouchDB will be kept around +-- until the manager is closed (http-enumerator will create more connections +-- if needed, it just keeps only one and closes the rest.) See the Pool +-- section for more information.+--+-- To access more than one database, the dbname entry can be set to the+-- empty string.+data CouchConnection = CouchConnection {+ host :: B.ByteString+ , port :: Int+ , manager :: H.Manager+ , dbname :: String+}++-- | Connect to a CouchDB database, call the supplied function, and then close +-- the connection.+-- +-- If you create your own instance of 'MonadCouch' instead of using +-- 'runCouch', this function will help you create the 'CouchConnection'. On +-- the other hand, if you want to implement connection pooling, you will not +-- be able to use withCouchConnection and must create the connection yourself.+withCouchConnection :: (MonadBaseControl IO m) => + String -- ^ Host+ -> Int -- ^ Port+ -> String -- ^ Database name. Just set empty if you + -- need access to many DBs+ -> (CouchConnection -> m a) -- ^ Function to run+ -> m a+withCouchConnection h p db f = + liftBaseOp (bracket H.newManager H.closeManager) go+ where + go m = f $ CouchConnection (BU8.fromString h) p m db++-- | A Couch DB Error. If the error comes from http, the http status code +-- is also given. Non-http errors include things like errors +-- parsing the response.+data CouchError = CouchError (Maybe Int) String+ deriving (Show,Typeable)+instance Exception CouchError++-- | A monad which allows access to the connection.+class (MonadIO m, MonadBaseControl IO m) => MonadCouch m where+ couchConnection :: m CouchConnection++instance (MonadIO m, MonadBaseControl IO m) => MonadCouch (ReaderT CouchConnection m) where+ couchConnection = ask++-- | Run a sequence of CouchDB actions.+--+-- The functions below to access CouchDB require a 'MonadCouch' instance to +-- access the connection information. 'ReaderT' is an instance of +-- 'MonadCouch', and /runCouch/ runs a sequence of database actions using +-- 'ReaderT'. See the top of this page for an example using /runCouch/.+--+-- The main reason to not use /runCouch/ is to obtain more control over +-- connection pooling. Also, if your db code is part of a larger monad, it +-- makes sense to just make the larger monad an instance of 'MonadCouch' and +-- skip the intermediate ReaderT, since then performance is improved by +-- eliminating one monad from the final transformer stack.+--+-- This function is a combination of 'withCouchConnection' and 'runReaderT'+runCouch :: (MonadIO m, MonadBaseControl IO m) => + String -- ^ Host+ -> Int -- ^ Port+ -> String -- ^ Database name. Just set empty if you + -- need access to many DBs+ -> ReaderT CouchConnection m a -- ^ CouchDB actions+ -> m a+runCouch h p d = withCouchConnection h p d . runReaderT++-- | A path to a Couch DB Object.+type Path = String++-- | Represents a revision of a Couch DB Document.+type Revision = T.Text++-- | Simplified version of 'couch''. +--+-- Response headers are ignored, and the response status is only used to+-- detect for an error, in which case a 'CouchError' is sent down the+-- 'Iteratee'.+couch :: MonadCouch m+ => HT.Method -- ^ Method+ -> Path -- ^ The dbname from the connection is + -- prepended to this path. Just set empty + -- if you need access to many DBs.+ -> HT.Query -- ^ Query arguments+ -> Iteratee B.ByteString m a -- ^ Iteratee to process the response if no + -- error occurs.+ -> H.RequestBody m -- ^ Body+ -> Iteratee B.ByteString m a+couch m p q i= couch' m p [] q (const i)++-- | The most general method of accessing CouchDB. This is a very thin wrapper +-- around 'H.http'. Most of the time you should use one of the other access +-- functions, but this function is needed for example to write and read +-- attachments that are not in JSON format.+-- +-- If CouchDB returns an error, the iteratee passed to this function is not+-- called and instead a 'CouchError' is sent out the Iteratee returned from+-- this function.+couch' :: MonadCouch m+ => HT.Method -- ^ Method+ -> Path -- ^ The dbname from the connection is + -- prepended to this path. Just set empty + -- if you need access to many DBs.+ -> HT.RequestHeaders -- ^ Headers+ -> HT.Query -- ^ Query arguments+ -> (HT.ResponseHeaders -> Iteratee B.ByteString m a) + -- ^ Function what returns Iteratee to + -- process the response if no error occurs.+ -> H.RequestBody m -- ^ Body+ -> Iteratee B.ByteString m a+couch' m p h q i b = Iteratee $ do+ conn <- couchConnection+ let req = H.def + { H.method = m+ , H.host = host conn+ , H.requestHeaders = h+ , H.port = port conn+ , H.path = BU8.fromString ("/" ++ dbname conn ++ "/" ++ p)+ , H.queryString = q+ , H.requestBody = b }+ runIteratee $ H.http req (\s h1 -> tryAccept s h1 i) (manager conn)++-- | Create CouchDB database regardless of presence. Roughly equivalent to+-- +-- > couchPut_ "" [] $ object []+-- +-- but catches 'CouchError' /412/.+couchPutDb :: MonadCouch m => + Path -- ^ If you passed a database name to 'withCouchConnection',+ -- 'runCouch', or 'CouchConnection', the path should be+ -- the empty string. If you passed the empty string to+ -- 'CouchConnection', then the dbname should be used here.+ -> m ()+couchPutDb p = + catch (couchPut_ p [] $ A.object []) handler+ where+ handler (CouchError (Just 412) _) = return ()+ handler e = throw e++-- | Delete a database.+couchDeleteDb :: MonadCouch m => + Path -- ^ If you passed a database name to 'withCouchConnection',+ -- 'runCouch', or 'CouchConnection', the path should be+ -- the empty string. If you passed the empty string to+ -- 'CouchConnection', then the dbname should be used here.+ -> m ()+couchDeleteDb p = run_ $ couch HT.methodDelete p []+ (yield () EOF) + (H.RequestBodyBS B.empty)++-- | Get Revision of a document. +couchRev :: MonadCouch m => Path -> m Revision+couchRev p = do+ v <- run_ $ couch' HT.methodHead p [] [] getEtag (H.RequestBodyBS B.empty)+ return $ T.dropAround (=='"') $ TE.decodeUtf8 v+ where+ getEtag h = yield (fromJust $ lookup "Etag" h) EOF++-- | Load a single object from couch DB.+couchGet :: MonadCouch m => + Path -- ^ the dbname is prepended to this string to + -- form the full path.+ -> HT.Query -- ^ Query arguments.+ -> m A.Object+couchGet p q = do + v <- run_ $ couch HT.methodGet p q (iterParser A.json) + (H.RequestBodyBS B.empty)+ either throw return $ valToObj v++-- | Put an object in Couch DB, returning the new Revision.+couchPut :: (MonadCouch m, A.ToJSON a) => + Path -- ^ the dbname is prepended to this string to + -- form the full path.+ -> HT.Query -- ^ Query arguments.+ -> a -- ^ The object to store.+ -> m Revision+couchPut p q val = do + v <- run_ $ couch HT.methodPut p q (iterParser A.json) body+ either (liftIO . throw) return (valToObj v >>= objToRev)+ where + body = jsonToReqBody val++-- | Put an object in Couch DB with revision, returning the new Revision.+couchPutRev :: (MonadCouch m, A.ToJSON a) => + Path -- ^ the dbname is prepended to this string to + -- form the full path.+ -> Revision -- ^ Document revision. For new docs provide empty string.+ -> HT.Query -- ^ Query arguments.+ -> a -- ^ The object to store.+ -> m Revision +couchPutRev p r q val = do+ v <- run_ $ couch' HT.methodPut p (ifMatch r) q + (\_ -> iterParser A.json) body+ either (liftIO . throw) return (valToObj v >>= objToRev)+ where + body = jsonToReqBody val+ ifMatch "" = []+ ifMatch rv = [("If-Match", TE.encodeUtf8 rv)]+ +-- | A version of 'couchPut' which ignores the return value. This is slightly +-- faster than / _ <- couchPut .../ since the JSON parser is not run.+couchPut_ :: (MonadCouch m, A.ToJSON a) + => Path -- ^ the dbname is prepended to this string to + -- form the full path.+ -> HT.Query -- ^ Query arguments.+ -> a -- ^ The object to store.+ -> m ()+couchPut_ p q val = run_ $ couch HT.methodPut p q (yield () EOF) body+ where body = jsonToReqBody val++-- | Delete the given revision of the object.+couchDelete :: MonadCouch m => + Path -- ^ the dbname is prepended to this string to + -- form the full path. + -> Revision -- ^ Document revision.+ -> m ()+couchDelete p r = run_ $ couch HT.methodDelete p + [("rev", Just $ TE.encodeUtf8 r)]+ (yield () EOF) + (H.RequestBodyBS B.empty)+ +-- | Load from a Couch DB View.+--+-- While you can use 'couchGet' on a view object, this function combines the+-- incredible power of http-enumerator and attoparsec to allow you to process +-- objects in constant space. As data is read from the network, it is fed into +-- attoparsec. When attoparsec completes parsing an object it is sent out +-- the enumerator.+--+-- The objects enumerated are the entries in the \"rows\" property of the +-- view result, which means they are not directly the objects you put into +-- the database. See <http://wiki.apache.org/couchdb/HTTP_view_API> for more +-- information. The objects inserted into the database are available in the +-- \"value\" entry, and can be extracted with the 'extractViewValue' +-- enumeratee, for example:+--+-- > couchView "mydesigndoc/_view/myview" +-- > [(fromString "key", Just $ fromString "3")] +-- > $= extractViewValue++couchView :: MonadCouch m => + Path -- ^ \/dbname\/_design\/ is prepended to the given path.+ -> HT.Query -- ^ Query arguments.+ -> Enumerator A.Object m a+couchView p q step = do + s <- lift $ run $ couch HT.methodGet ("_design/" ++ p) q + (parseView step) (H.RequestBodyBS B.empty)+ either throwError returnI s+++-- | An enumeratee to extract the \"value\" member of JSON objects.+--+-- This is useful to extract the object from the data returned from a view. +-- For example, Couch DB will return objects that look like the following:+--+-- > { "id":"64ACF01B05F53...", "key":null, "value": { some object } }+--+-- and this enumeratee will extract /{some object}/+extractViewValue :: Monad m => Enumeratee A.Object A.Object m a+extractViewValue = + mapEither f+ where + f v = case M.lookup "value" v of+ (Just (A.Object o)) -> Right o+ _ -> Left $ CouchError Nothing "view does not contain value"++-------------------------------------------------------------------------------+--- Helper Code+-------------------------------------------------------------------------------++-- | Internal try accept +tryAccept :: Monad m =>+ HT.Status+ -> HT.ResponseHeaders+ -> (HT.ResponseHeaders -> Iteratee B.ByteString m b)+ -> Iteratee B.ByteString m b+tryAccept (HT.Status 200 _) h it = it h+tryAccept (HT.Status 201 _) h it = it h+tryAccept (HT.Status 202 _) h it = it h+tryAccept (HT.Status 304 _) h it = it h+tryAccept (HT.Status c ms) _ _ = do+ v <- catchError (iterParser A.json) (\_ -> yield "" EOF)+ throwError $ CouchError (Just c) $ msg v+ where + msg v = BU8.toString ms ++ reason v+ reason (A.Object v) = case M.lookup "reason" v of+ Just (A.String t) -> ": " ++ T.unpack t+ _ -> ""+ reason _ = []++-- | Converts a json object into a 'H.RequestBodyLBS'+jsonToReqBody :: (A.ToJSON a, Monad m) => a -> H.RequestBody m+jsonToReqBody val = H.RequestBodyLBS $ A.encode val+-- where +-- jbuilder = AE.fromValue $ A.toJSON val+-- enum (Continue k) = k (Chunks [jbuilder])+-- enum step = returnI step+-- trans = BLB.fromLazyByteString . TLE.encodeUtf8+-- untrans = TLE.decodeUtf8 . BL.toLazyByteString++-- | Convers a value to an object+valToObj :: A.Value -> Either CouchError A.Object+valToObj (A.Object o) = Right o+valToObj _ = Left $ CouchError Nothing "Couch DB did not return an object"++-- | Converts an object to a revision+objToRev :: A.Object -> Either CouchError Revision+objToRev o = case M.lookup "rev" o of+ (Just (A.String r)) -> Right r+ _ -> Left $ CouchError Nothing "unable to find revision" ++data CommaOrCloseBracket = Comma | CloseBracket++commaOrClose :: Parser CommaOrCloseBracket+commaOrClose = do+ skipWhile (\c -> c /= 44 && c /= 93) <?> + "Checking for next comma"+ w <- anyWord8+ if w == 44 then return Comma else return CloseBracket++-- | The main loop of processing the view rows.+viewLoop :: MonadIO m => Enumeratee B.ByteString A.Object m a+viewLoop (Yield a _) = return $ Yield a EOF+viewLoop (Error err) = return $ Error err+viewLoop (Continue k) = do + v <- iterParser (A.json <?> "json object")+ vobj <- case v of+ (A.Object o) -> return o+ _ -> throwError $ CouchError Nothing "view entry is not an object"+ step' <- lift $ runIteratee $ k $ Chunks [vobj]+ res <- iterParser (commaOrClose <?> "comma or close")+ case res of+ Comma -> viewLoop step'+ CloseBracket -> case step' of+ (Continue k') -> lift $ runIteratee $ k' EOF+ _ -> return step'++viewStart :: Parser Bool+viewStart = do+ _ <- string "{\"total_rows\":"+ skipWhile (\x -> x >= 48 && x <= 57)+ _ <- string ",\"offset\":"+ skipWhile (\x -> x >= 48 && x <= 57)+ _ <- string ",\"rows\":["+ (string "]}" >> return False) <|> return True++-- | Enumeratee to parse the data returned by a view.+parseView :: MonadIO m => Enumeratee B.ByteString A.Object m a+parseView (Yield a _) = return $ Yield a EOF+parseView (Error err) = return $ Error err+parseView (Continue k) = do + b <- iterParser (viewStart <?> "start of view") + if b then viewLoop $ Continue k+ else lift $ runIteratee $ k EOF+++mapEither :: (Exception e, Monad m) => (a -> Either e b) -> Enumeratee a b m c+mapEither f = checkDone (continue . step) where+ step k EOF = yield (Continue k) EOF+ step k (Chunks xs) = case Prelude.mapM f xs of+ Left err -> throwError err+ Right xs' -> k (Chunks xs') >>== mapEither f++-- $pool+-- The 'H.Manager' stored in the CouchConnection maintains a pool of open +-- connections in an IORef, but keeps a maximum of one open connection per +-- (host,port) pair. Also, each time 'runCouch' or 'withCouchConnection' is +-- called, a new manager (and thus new connections) is created and destroyed.+--+-- For more precise control over pooling, use the +-- <http://hackage.haskell.org/package/resource-pool> or+-- <http://hackage.haskell.org/package/pool> packages combined with the+-- 'H.newManager' and 'H.closeManager' functions.+--+-- For example, the following code using the resource-pool package runs a +-- /ReaderT CouchConnection m/ action using a HTTP connection from a pool.+-- +-- > runPooledCouch :: MonadCatchIO m => +-- > Pool Manager +-- > -> String +-- > -> Int +-- > -> String +-- > -> ReaderT CouchConnection m a -> m a+-- > runPooledCouch p host port dbname c = withResource p $ \m -> do+-- > runReaderT c $ CouchConnection (BU8.fromString host) port m dbname++-- $yesod+-- Integrating couchdb-enumerator with yesod looks something the way the +-- scaffold sets up the YesodPersist instance.+--+-- > data MyFoundation = MyFoundation +-- > { ... (normal yesod stuff in the foundation type)+-- > , connPool :: Data.Pool.Pool H.Manager+-- > , dbLocation :: B.ByteString+-- > , databaseName :: String }+-- >+-- > newtype CouchDBPersist m a = CouchDBPersist { +-- > unCouchDBPersist :: ReaderT CouchConnection m a }+-- > deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, +-- > MonadTransControl, MonadBaseControl, MonadPlus, MonadCouch)+-- >+-- > instance YesodPersist MyFoundation where+-- > type YesodPersistBackend = CouchDBPersist+-- > runDB r = do +-- > pool <- connPool <$> getYesod+-- > loc <- dbLocation <$> getYesod+-- > db <- databaseName <$> getYesod+-- > Data.Pool.withPool' pool $ \m ->+-- > runReaderT (unCouchDBPersist r) $ +-- > CouchConnection loc 5984 m db+--+-- Then you can write handler code as follows:+--+-- > getFooR :: PersonID -> Handler RepPlain+-- > getFooR p = do+-- > person <- runDB $ couchGet p []+-- > return $ RepPlain $ toContent $ Aeson.encode $ maybe Aeson.null person+--+-- Alternatively, you don't need to make your Foundation an instance of +-- YesodPersist, you could supply your own runCouchDB function which is just +-- a version of runDB specialized to your foundation and just use that +-- from the handlers.++-- vim: set expandtab:set tabstop=4:
+ src/Database/CouchDB/Enumerator/Generic.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++{- | A convenient wrapper around "Database.CouchDB.Enumerator" and "Data.Aeson.Generic"++The aeson library has the ability to encode and decode JSON using the generic+Data and Typeable classes via the "Data.Aeson.Generic" module. It isn't too+hard to use 'AG.fromJSON' and 'AG.toJSON' combined with the functions in+"Database.CouchDB.Enumerator", except that in several cases Couch DB uses+system fields /_id/ and /_rev/ which present a small difficulty.++For example, Couch DB will return an object like the following++> {+> "_id": "somedoc",+> "_rev": "11-52b4f9b471de393fab82313b9d8571c1",+> "foo": 3,+> "bar": true+> }++Also, occasionally (not always) the /_rev/ field must be present in an object+that is sent to Couch DB during a PUT.++The short wrapper functions in this module take care of handling the /_id/+and /_rev/ fields separately from the encoding and decoding to the generic+data structure.++> import Data.Data (Data, Typeable)+> import Data.Bytestring (Bytestring)+> import Database.CouchDB.Enumerator hiding (couchGet, couchPut)+> import qualified Database.CouchDB.Enumerator.Generic as G+> +> data Rec = Rec {+> field1 :: Int+> , field2 :: ByteString+> } deriving (Data, Typeable)+> +> testCouch :: IO ()+> testCouch = runCouch "localhost" 5984 "test" $ do+> -- Insert doc+> rev1 <- G.couchPut "doc1" Nothing [] $ Rec 1 "foo"+> -- Get doc +> G.CouchDoc p r doc1 <- G.couchGet "doc1" []+> -- New revision+> rev2 <- G.couchPut "doc1" (Just rev1) [] $ Rec 2 "bar"+-}++module Database.CouchDB.Enumerator.Generic (+ -- * Couch DB documents API for Generic+ CouchDoc(..),+ couchGet,+ couchPut,+ couchPut',+ -- * Couch DB views API for Generic+ consumeView,+ parseGeneric+) where++import Prelude hiding (catch)++import Control.Monad (mzero)+import Control.Exception.Lifted (catch, throw)+import Control.Applicative++import Data.Data (Data)+import Data.Aeson+import qualified Data.Aeson.Generic as AG++import Data.Enumerator (($=), ($$), Enumeratee, run_)+import qualified Data.Enumerator.List as EL (map, consume)++import qualified Network.HTTP.Types as HT++import Database.CouchDB.Enumerator hiding (couchGet, couchPut)+import qualified Database.CouchDB.Enumerator as CE (couchGet, couchPutRev)++-- | CouchDB document with path and revision.+data CouchDoc a = CouchDoc Path Revision a deriving (Show)++-- | Doc signature. Just for parsing.+data DocSig = DocSig String Revision++instance FromJSON DocSig where+ parseJSON (Object v) = DocSig <$>+ v .: "_id" <*>+ v .:? "_rev" .!= ""+ parseJSON _ = mzero++-- | Load a single object from couch DB.+couchGet :: (MonadCouch m, Data a) => + Path -- ^ the dbname is prepended to this string to + -- form the full path.+ -> HT.Query -- ^ Query arguments.+ -> m (CouchDoc a)+couchGet p q = do+ res <- CE.couchGet p q+ case fromJSON $ Object res of+ Success (DocSig i r) -> return $ CouchDoc i r $ parseObjToGen res+ _ -> throw $ CouchError Nothing "Error parse signature."++-- | Put an object in Couch DB, returning the new Revision. +couchPut :: (MonadCouch m, Data a) =>+ Path -- ^ the dbname is prepended to this string to + -- form the full path.+ -> Revision -- ^ Revision. Empty string for new documents.+ -> HT.Query -- ^ Query arguments.+ -> a -- ^ Data+ -> m Revision+couchPut p r q a = + CE.couchPutRev p r q $ AG.toJSON a+ +-- | Brute force version of 'couchPut'. Stores document regardless of presence+-- in database (catches 'couchRev' 'CouchError' /404/). +--+-- This version is slower that 'couchPut' because it first tries to find the+-- document revision. +--+-- Also, there are no guarantees that some other thread or+-- program updated the object (and thus generated a new revision) between loading+-- the existing revision and deleting the object. If this occurs, an error will+-- still be thrown.+couchPut' :: (MonadCouch m, Data a) =>+ Path -- ^ the dbname is prepended to this string to + -- form the full path.+ -> HT.Query -- ^ Query arguments.+ -> a -- ^ Data+ -> m Revision +couchPut' p q a = do+ rev1 <- catch (couchRev p) handler+ couchPut p rev1 q a+ where+ handler (CouchError (Just 404) _) = return ""+ handler e = throw e++-- | Strictly consumes all view result. Use this if all view data is +-- mandatory and all errors must be handled.+consumeView :: (MonadCouch m, Data a) =>+ Path -- ^ the dbname is prepended to this string to + -- form the full path.+ -> HT.Query -- ^ Query arguments.+ -> m [a] +consumeView p q = + run_ $ couchView p q $= extractViewValue $= parseGeneric $$ EL.consume++-- | Parse 'Object' from 'extractViewValue'.+parseGeneric :: (Monad m, Data a) => Enumeratee Object a m b +parseGeneric = EL.map parseObjToGen++-- | Parse 'Value' to generic.+parseObjToGen :: Data a => Object -> a+parseObjToGen v = case AG.fromJSON $ Object v of+ Success s -> s+ _ -> throw $ CouchError Nothing "Error parse to Generic"
+ test/Database/CouchDB/Enumerator/Test/Basic.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Basic tests +module Database.CouchDB.Enumerator.Test.Basic where + +import Control.Monad +import Control.Monad.Trans.Class (lift) +import qualified Control.Exception.Lifted as E +import Data.Aeson ((.=)) +import qualified Data.Aeson as A +import qualified Data.HashMap.Lazy as M +import Data.List (nubBy) + +import Database.CouchDB.Enumerator +import Database.CouchDB.Enumerator.Test.Util + +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion) +import Test.QuickCheck (sample', arbitrary) + +tests :: Test +tests = testGroup "Basic" [ + testGroup "DB" [ + testCouchCase "basic connection" connectTest + , testCouchCase "basic error" missingObjectTest + , testCouchCase "conflict" conflictError + --, testCouchProperty "single insert" (1,7) insertTest + , testCouchCase "insert" insertTestCase + , testCouchCase "basic delete" deleteTest + , testCase "Delete noexistent" case_deleteNoexistentDb + + -- TODO: right now, the following test screws up other tests by deleting the db. + -- Perhaps the code should be updated to put the database at the beginning of each test? + --, testCouchCase "Double put and delete" case_doublePutAndDel + ] + ] + +connectTest :: CouchT IO () +connectTest = do + v <- couchGet "" [] + lift $ assertObjMember "db_name" (assertStr "testcouchenum") v + +missingObjectTest :: CouchT IO () +missingObjectTest = assertRecvError (Just 404) $ couchGet "jaosihaweoghaweiouhawef" [] + +conflictError :: CouchT IO () +conflictError = do + E.handle catch404 $ do rev <- couchRev "conflicttest" + couchDelete "conflicttest" rev + --E.handle catch404 $ couchRev "somebadobject" >> return () + couchPut_ "conflicttest" [] $ A.object [ "foo" .= True ] + return () + where catch404 e@(CouchError c _) = unless (c == Just 404) $ E.throwIO e + +insertTestCase :: CouchT IO () +insertTestCase = replicateM_ 20 $ do + objs <- lift $ sample' arbitrary + insertTest objs + +insertTest :: [(Int,ArbitraryObject,ArbitraryObject,ArbitraryObject)] -> CouchT IO () +insertTest objs = do + let objs' = nubBy (\(a,_,_,_) (b,_,_,_) -> a == b) objs + let keys = map (("otest"++) . show . (\(a,_,_,_) -> a)) objs' + let vals1 = map (\(_,ArbitraryObject a,_,_) -> a) objs' + let vals2 = map (\(_,_,ArbitraryObject a,_) -> a) objs' + let vals3 = map (\(_,_,_,ArbitraryObject a) -> a) objs' + + mapM_ clearObject keys + + rev <- forM (zip keys vals1) $ \(k,o) -> + couchPut k [] o + + forM_ (zip3 rev keys vals1) $ \(r,k,o) -> do + checkLoad k $ M.insert "_rev" (A.toJSON r) o + checkRevision k r + + rev2 <- forM (zip3 rev keys vals2) $ \(r,k,o) -> + couchPut k [] $ M.insert "_rev" (A.toJSON r) o + + forM_ (zip3 rev2 keys vals2) $ \(r,k,o) -> do + checkLoad k $ M.insert "_rev" (A.toJSON r) o + checkRevision k r + + rev3 <- forM (zip3 rev2 keys vals3) $ \(r,k,o) -> + couchPutRev k r [] o + + forM_ (zip3 rev3 keys vals3) $ \(r,k,o) -> do + checkLoad k $ M.insert "_rev" (A.toJSON r) o + checkRevision k r + +deleteTest :: CouchT IO () +deleteTest = do + (ArbitraryObject obj) <- liftM (head . drop 5) $ lift $ sample' arbitrary + + clearObject "deltest" + + rev <- couchPut "deltest" [] obj + checkLoad "deltest" obj + couchDelete "deltest" rev + assertRecvError (Just 404) $ couchGet "deltest" [] + + +case_doublePutAndDel :: CouchT IO () +case_doublePutAndDel = do + couchPutDb "" + couchPutDb "" + couchDeleteDb "" + +-- | A test with an empty db +case_deleteNoexistentDb :: Assertion +case_deleteNoexistentDb = runCouch "localhost" 5984 "" $ + checkError (Just 404) $ couchDeleteDb "cdbe_noexistent"
+ test/Database/CouchDB/Enumerator/Test/Generic.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +-- | Generic tests. For tests make database "testcouchdbenum" +module Database.CouchDB.Enumerator.Test.Generic where + +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + +import Control.Monad.IO.Class (liftIO) + +import Data.Data (Typeable, Data) +import Data.ByteString (ByteString) +import qualified Data.Text as T +import Data.Text.Encoding + +import Data.Aeson +import qualified Data.Enumerator.List as EL +import Data.Enumerator hiding (map, mapM) + +import Database.CouchDB.Enumerator +import qualified Database.CouchDB.Enumerator.Generic as CG + +tests :: Test +tests = testGroup "Generic" [ + testCase "Put and Get" case_forsed, + testCase "Iter View" case_view, + testCase "Strict View" case_viewConsume + ] + +-- | View value +data DumpV = DumpV {rev :: String} deriving (Show, Eq, Data, Typeable) + +data SimpleDoc = SimpleDoc { + simpleFoo :: Int, + simpleBar :: Int, + simpleStr :: ByteString +} deriving (Show, Eq, Data, Typeable) + +case_forsed :: Assertion +case_forsed = runCouch "localhost" 5984 "test_cdbe_gen" $ do + couchPutDb "" + _ <- CG.couchPut' "gen_doc" [] $ genDoc 0 + CG.CouchDoc _ _ r <- CG.couchGet "gen_doc" [] + liftIO $ r @=? genDoc 0 + couchDeleteDb "" + return () + +case_view :: Assertion +case_view = runCouch "localhost" 5984 "test_cdbe_gen_view" $ do + couchPutDb "" + couchPut_ "_design/dataviews" [] viewObj + mapM_ (\n -> CG.couchPut' (show n) [] $ genDoc n) ([1..5] :: [Int]) + r <- run_ $ couchView "dataviews/_view/my" [] + $= extractViewValue $= CG.parseGeneric $$ EL.consume + mapM_ (\(ex, f) -> liftIO $ ex @=? f) + $ zip r $ map genDoc ([1..5] :: [Int]) + couchDeleteDb "" + +case_viewConsume :: Assertion +case_viewConsume = runCouch "localhost" 5984 "test_cdbe_gen_view" $ do + couchPutDb "" + couchPut_ "_design/dataviews" [] viewObj + mapM_ (\n -> CG.couchPut' (show n) [] $ genDoc n) ([1..5] :: [Int]) + r <- CG.consumeView "dataviews/_view/my" [] + mapM_ (\(ex, f) -> liftIO $ ex @=? f) + $ zip r $ map genDoc ([1..5] :: [Int]) + couchDeleteDb "" + +viewObj :: Value +viewObj = object + [ "language" .= ("javascript" :: T.Text) + , "views" .= object [ "my" .= object + [ "map" .= ("function(doc) {emit(null, doc); }" :: T.Text) ] + ] ] + +genDoc :: Int -> SimpleDoc +genDoc n = SimpleDoc n n $ encodeUtf8 "И проч" + + + + + +
+ test/Database/CouchDB/Enumerator/Test/Util.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.CouchDB.Enumerator.Test.Util ( + CouchT + , testCouch + , testCouchCase + , testCouchProperty + , isSubmapOf + , assertStr + , assertObjMember + , checkError + , assertRecvError + , checkRevision + , checkLoad + , clearObject + , ArbitraryObject(..) +)where + +import Control.Applicative +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Exception.Lifted as E +import Control.Monad +import Control.Monad.Trans.Reader +import qualified Data.Aeson as A +import qualified Data.HashMap.Lazy as M +import Data.Maybe (fromJust) +import Database.CouchDB.Enumerator +import qualified Data.Text as T +import qualified Data.Vector as V + +import Test.Framework (Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit (testCase) +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Test.HUnit hiding (Test, path) + +type CouchT m a = ReaderT CouchConnection m a + +testCouch :: CouchT IO a -> IO () +testCouch c = withCouchConnection "localhost" 5984 "testcouchenum" (runReaderT c) >> return () + +testCouchCase :: String -> CouchT IO a -> Test +testCouchCase s c = testCase s $ testCouch c + +testCouchProperty :: (Show a, Arbitrary a) => String -> (Int,Int) -> ([a] -> CouchT IO b) -> Test +testCouchProperty s i f = testProperty s $ monadicIO $ do + len <- pick $ choose i + lst <- pick $ vector len + run $ testCouch $ f lst + +-- | Assert that the value is a string, and check that it matches the given string +assertStr :: T.Text -> A.Value -> Assertion +assertStr t (A.String t') = unless (t == t') $ assertFailure $ "strings are not equal. expecting " + ++ T.unpack t ++ " received " ++ T.unpack t' +assertStr _ _ = assertFailure "expecting a JSON string" + +member :: T.Text -> A.Object -> Bool +member k o = M.lookup k o /= Nothing + +isSubmapOf :: A.Object -> A.Object -> Bool +isSubmapOf x y = 0 == M.size (M.difference x y) + +-- | Assert that the given key exists, and the value matches the given assertion +assertObjMember :: T.Text -> (A.Value -> Assertion) -> A.Object -> Assertion +assertObjMember t f x = do + assertBool (T.unpack t ++ " is missing") $ member t x + f $ fromJust $ M.lookup t x + +-- | Check an action for a couch error +checkError :: MonadBaseControl IO m => Maybe Int -> m () -> m () +checkError code m = E.catch m handler + where handler e@(CouchError c _) = unless (c == code) $ E.throwIO e + +-- | Expect a couch error with the given code +assertRecvError :: (MonadIO m, MonadBaseControl IO m) => Maybe Int -> m a -> m () +assertRecvError code v = checkError code $ v >> liftIO (assertFailure "was expecting a couch error") + +-- | Check that an object in the database matches the given value. +checkLoad :: String -> A.Object -> CouchT IO () +checkLoad n obj = do + obj' <- couchGet n [] + lift $ assertBool "returned object does not match" $ isSubmapOf obj obj' + +checkRevision :: String -> Revision -> CouchT IO () +checkRevision n r = do + r' <- couchRev n + lift $ assertBool "returned revision does not match" $ r == r' + +-- | Delete the given object, useful for the start of a test +clearObject :: String -> CouchT IO () +clearObject n = checkError (Just 404) go + where go = do rev <- couchRev n + couchDelete n rev + +newtype ArbitraryObject = ArbitraryObject { unArbObject :: A.Object } + deriving (Show,Eq,A.FromJSON,A.ToJSON) + +instance Arbitrary T.Text where + arbitrary = liftM T.pack $ listOf $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ " 1234567890!@#$%^&*()+|" + shrink "" = [] + shrink x = [T.tail x] + +arbBaseValue :: Gen A.Value +arbBaseValue = oneof [ A.String <$> arbitrary + , A.toJSON <$> (arbitrary :: Gen Integer) + , A.Bool <$> arbitrary + , return A.Null + ] + +arbObject :: Bool -> Gen A.Object +arbObject onlyBase = do nkeys <- choose (3,15) + keys <- vectorOf nkeys arbitrary + vals <- vectorOf nkeys $ if onlyBase + then arbBaseValue + else frequency [ (8, arbBaseValue) + , (1, A.Object <$> arbObject False) + , (1, A.Array <$> arbArrayOfObj) + ] + + return $ M.fromList $ zip keys vals + +arbArrayOfObj :: Gen A.Array +arbArrayOfObj = do len <- choose (1,20) + vals <- vectorOf len (A.Object <$> arbObject False) + return $ V.fromList vals + +instance Arbitrary ArbitraryObject where + arbitrary = ArbitraryObject <$> arbObject True
+ test/Database/CouchDB/Enumerator/Test/View.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Database.CouchDB.Enumerator.Test.View(+ tests+) where++import Control.Monad+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Reader+import Data.Aeson ((.=))+import qualified Data.Aeson as A+import qualified Data.ByteString.UTF8 as BU8+import Data.Enumerator hiding (map, length, head, run, drop)+import qualified Data.Enumerator.List as EL+import Data.List (find, deleteBy)+import qualified Data.HashMap.Lazy as M+import qualified Data.Text as T++import Test.Framework (Test, testGroup)+import Test.QuickCheck (sample', arbitrary)++import Database.CouchDB.Enumerator+import Database.CouchDB.Enumerator.Test.Util++tests :: Test+tests = testGroup "Views" [+ --testCouchProperty "basic" (12,13) views+ testCouchCase "basic" viewCase+ ]++checkEqual :: (Monad m) => [A.Object] -> [A.Object] -> Iteratee a m ()+checkEqual [] [] = return ()+checkEqual [] (x:_) = error $ "Extra object in list 2 " ++ show (A.encode x)+checkEqual (x:xs) lst2 = case find (isSubmapOf x) lst2 of+ Nothing -> error $ "Unable to find " ++ show (A.encode $ A.Object x)+ Just _ -> checkEqual xs $ deleteBy isSubmapOf x lst2++assertViewRet :: (MonadIO m) => [A.Object] -> Enumerator A.Object m () -> m ()+assertViewRet lst e = run_ (e $$ EL.consume >>= checkEqual lst)++addKeys :: Int -> Int -> Int -> ArbitraryObject -> A.Object+addKeys u g t (ArbitraryObject o) = o `M.union` M.fromList [ ("user", A.toJSON u)+ , ("group", A.toJSON g)+ , ("otype", A.toJSON t)+ ]++addView :: CouchT IO ()+addView = couchPut_ "_design/dataviews" [] viewObj where+ viewObj = A.object + [ "language" .= ("javascript" :: T.Text)+ , "views" .= A.object+ [ "bytype" .= A.object+ [ "map" .= ("function(doc) {\+ \ emit([doc.user,doc.group,doc.otype], doc); \+ \}" :: T.Text)+ ]+ ]+ ]++queryByType :: Integer -> Integer -> Integer -> Enumerator A.Object (ReaderT CouchConnection IO) b+queryByType u g t = couchView path query $= extractViewValue+ where path = "dataviews/_view/bytype"+ key = "[" ++ show u ++ "," ++ show g ++ "," ++ show t ++ "]"+ query = [(BU8.fromString "key", Just $ BU8.fromString key)]++queryByGroup :: Integer -> Integer -> Enumerator A.Object (ReaderT CouchConnection IO) b+queryByGroup u g = couchView path query $= extractViewValue+ where path = "dataviews/_view/bytype"+ skey = "[" ++ show u ++ "," ++ show g ++ "]"+ ekey = "[" ++ show u ++ "," ++ show g ++ ",{}]"+ query = [ (BU8.fromString "startkey", Just $ BU8.fromString skey)+ , (BU8.fromString "endkey" , Just $ BU8.fromString ekey)+ ]++viewCase :: CouchT IO ()+viewCase = replicateM_ 20 $ do+ objs <- liftIO $ sample' arbitrary+ views objs++views :: [ArbitraryObject] -> CouchT IO ()+views lst = do+ let (group1,x1) = splitAt 3 lst+ (group2,x2) = splitAt 3 x1+ (group3,x3) = splitAt 3 x2+ (group4,_ ) = splitAt 3 x3++ g1key = map (("view"++) . show) ([0..2] :: [Int])+ g1obj = map (addKeys 0 0 0) group1+ g2key = map (("view"++) . show) ([5..7] :: [Int])+ g2obj = map (addKeys 0 0 1) group2+ g3key = map (("view"++) . show) ([10..12] :: [Int])+ g3obj = map (addKeys 0 1 0) group3+ g4key = map (("view"++) . show) ([15..17] :: [Int])+ g4obj = map (addKeys 1 0 0) group4++ mapM_ clearObject $ g1key ++ g2key ++ g3key ++ g4key++ checkError (Just 409) addView++ forM_ (zip g1key g1obj ++ zip g2key g2obj ++ zip g3key g3obj ++ zip g4key g4obj) $ \(k,o) ->+ couchPut_ k [] o++ assertViewRet [] $ queryByType 0 0 2+ assertViewRet [] $ queryByType 0 2 0+ assertViewRet [] $ queryByType 2 0 0++ assertViewRet g1obj $ queryByType 0 0 0+ assertViewRet g2obj $ queryByType 0 0 1+ assertViewRet g3obj $ queryByType 0 1 0+ assertViewRet g4obj $ queryByType 1 0 0++ assertViewRet (g1obj ++ g2obj) $ queryByGroup 0 0+ assertViewRet g3obj $ queryByGroup 0 1+ assertViewRet g4obj $ queryByGroup 1 0++ assertViewRet [] $ queryByGroup 0 2+ assertViewRet [] $ queryByGroup 2 0
+ test/Main.hs view
@@ -0,0 +1,20 @@+-- | Tests. TODO + +module Main where + +import Test.Framework (defaultMain, Test) + +import qualified Database.CouchDB.Enumerator.Test.Basic +import qualified Database.CouchDB.Enumerator.Test.View +import qualified Database.CouchDB.Enumerator.Test.Generic + +main :: IO () +main = defaultMain tests + +-- | All tests +tests :: [Test] +tests = [ + Database.CouchDB.Enumerator.Test.Basic.tests + , Database.CouchDB.Enumerator.Test.View.tests + , Database.CouchDB.Enumerator.Test.Generic.tests + ]
− tests.hs
@@ -1,268 +0,0 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main where--import Control.Applicative-import qualified Control.Exception.Lifted as E-import Control.Monad-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Reader-import Data.Aeson ((.=))-import qualified Data.Aeson as A-import qualified Data.ByteString.UTF8 as BU8-import Data.Enumerator hiding (map, length, head, run, drop)-import qualified Data.Enumerator.List as EL-import Data.List (find, deleteBy, nubBy)-import qualified Data.HashMap.Lazy as M-import Data.Maybe (fromJust)-import qualified Data.Text as T-import qualified Data.Vector as V--import Database.CouchDB.Enumerator--import Test.Framework (defaultMain, Test)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.Framework.Providers.HUnit (testCase)--import Test.QuickCheck-import Test.QuickCheck.Monadic-import Test.HUnit hiding (Test, path)--main :: IO ()-main = defaultMain tests--tests :: [Test]-tests = [ testCouchCase "basic connection" connectTest- , testCouchCase "basic error" missingObjectTest- , testCouchProperty "single insert" (1,7) insertTest- , testCouchCase "basic delete" deleteTest- , testCouchProperty "view" (12,13) views- ]- --------------------------------------------------------------------------------------- Test Helpers-------------------------------------------------------------------------------------type CouchT m a = ReaderT CouchConnection m a--testCouch :: CouchT IO a -> IO ()-testCouch c = withCouchConnection "172.16.5.2" 5984 "testcouchenum" (runReaderT c) >> return ()--testCouchCase :: String -> CouchT IO a -> Test-testCouchCase s c = testCase s $ testCouch c--testCouchProperty :: (Show a, Arbitrary a) => String -> (Int,Int) -> ([a] -> CouchT IO b) -> Test-testCouchProperty s i f = testProperty s $ monadicIO $ do- len <- pick $ choose i- lst <- pick $ vector len- run $ testCouch $ f lst---- | Assert that the value is a string, and check that it matches the given string-assertStr :: T.Text -> A.Value -> Assertion-assertStr t (A.String t') = unless (t == t') $ assertFailure $ "strings are not equal. expecting " - ++ T.unpack t ++ " received " ++ T.unpack t'-assertStr _ _ = assertFailure "expecting a JSON string"--member :: T.Text -> A.Object -> Bool-member k o = M.lookup k o /= Nothing--isSubmapOf :: A.Object -> A.Object -> Bool-isSubmapOf x y = 0 == M.size (M.difference x y)---- | Assert that the given key exists, and the value matches the given assertion-assertObjMember :: T.Text -> (A.Value -> Assertion) -> A.Object -> Assertion-assertObjMember t f x = do- assertBool (T.unpack t ++ " is missing") $ member t x- f $ fromJust $ M.lookup t x---- | Check an action for a couch error-checkError :: MonadBaseControl IO m => Maybe Int -> m () -> m ()-checkError code m = E.catch m handler- where handler e@(CouchError c _) = unless (c == code) $ E.throwIO e---- | Expect a couch error with the given code-assertRecvError :: (MonadIO m, MonadBaseControl IO m) => Maybe Int -> m a -> m ()-assertRecvError code v = checkError code $ v >> liftIO (assertFailure "was expecting a couch error")---- | Check that an object in the database matches the given value.-checkLoad :: String -> A.Object -> CouchT IO ()-checkLoad n obj = do- obj' <- couchGet n []- lift $ assertBool "returned object does not match" $ isSubmapOf obj obj'---- | Delete the given object, useful for the start of a test-clearObject :: String -> CouchT IO ()-clearObject n = checkError (Just 404) go- where go = do obj <- couchGet n []- unless (member "_rev" obj) $ fail "_rev is missing"- let (A.String rev) = fromJust $ M.lookup "_rev" obj- couchDelete n rev--newtype ArbitraryObject = ArbitraryObject { unArbObject :: A.Object }- deriving (Show,Eq,A.FromJSON,A.ToJSON)--instance Arbitrary T.Text where- arbitrary = liftM T.pack $ listOf $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ " 1234567890!@#$%^&*()+|"- shrink "" = []- shrink x = [T.tail x]--arbBaseValue :: Gen A.Value-arbBaseValue = oneof [ A.String <$> arbitrary- , A.toJSON <$> (arbitrary :: Gen Integer)- , A.Bool <$> arbitrary- , return A.Null- ]--arbObject :: Bool -> Gen A.Object-arbObject onlyBase = do nkeys <- choose (3,15)- keys <- vectorOf nkeys arbitrary- vals <- vectorOf nkeys $ if onlyBase- then arbBaseValue- else frequency [ (8, arbBaseValue)- , (1, A.Object <$> arbObject False)- , (1, A.Array <$> arbArrayOfObj)- ]-- return $ M.fromList $ zip keys vals --arbArrayOfObj :: Gen A.Array-arbArrayOfObj = do len <- choose (1,20)- vals <- vectorOf len (A.Object <$> arbObject False)- return $ V.fromList vals--instance Arbitrary ArbitraryObject where- arbitrary = ArbitraryObject <$> arbObject True---------------------------------------------------------------------------------------- Base Tests-------------------------------------------------------------------------------------connectTest :: CouchT IO ()-connectTest = do- v <- couchGet "" []- lift $ assertObjMember "db_name" (assertStr "testcouchenum") v--missingObjectTest :: CouchT IO ()-missingObjectTest = assertRecvError (Just 404) $ couchGet "jaosihaweoghaweiouhawef" []--insertTest :: [(Int,ArbitraryObject,ArbitraryObject)] -> CouchT IO ()-insertTest objs = do- let objs' = nubBy (\(a,_,_) (b,_,_) -> a == b) objs- let keys = map (("otest"++) . show . (\(a,_,_) -> a)) objs'- let vals1 = map (\(_,ArbitraryObject a,_) -> a) objs'- let vals2 = map (\(_,_,ArbitraryObject a) -> a) objs'-- mapM_ clearObject keys-- rev <- forM (zip keys vals1) $ \(k,o) -> couchPut k [] o- forM_ (zip3 rev keys vals1) $ \(r,k,o) ->- checkLoad k $ M.insert "_rev" (A.toJSON r) o-- rev2 <- forM (zip3 rev keys vals2) $ \(r,k,o) ->- couchPut k [] $ M.insert "_rev" (A.toJSON r) o-- forM_ (zip3 rev2 keys vals2) $ \(r,k,o) ->- checkLoad k $ M.insert "_rev" (A.toJSON r) o--deleteTest :: CouchT IO ()-deleteTest = do- (ArbitraryObject obj) <- liftM (head . drop 5) $ lift $ sample' arbitrary-- clearObject "deltest"-- rev <- couchPut "deltest" [] obj- checkLoad "deltest" obj- couchDelete "deltest" rev- assertRecvError (Just 404) $ couchGet "deltest" []---------------------------------------------------------------------------------------- View Tests-------------------------------------------------------------------------------------checkEqual :: (Monad m) => [A.Object] -> [A.Object] -> Iteratee a m ()-checkEqual [] [] = return ()-checkEqual [] (x:_) = error $ "Extra object in list 2 " ++ show (A.encode x)-checkEqual (x:xs) lst2 = case find (isSubmapOf x) lst2 of- Nothing -> error $ "Unable to find " ++ show (A.encode $ A.Object x)- Just _ -> checkEqual xs $ deleteBy isSubmapOf x lst2--assertViewRet :: (MonadIO m) => [A.Object] -> Enumerator A.Object m () -> m ()-assertViewRet lst e = run_ (e $$ EL.consume >>= checkEqual lst)--addKeys :: Int -> Int -> Int -> ArbitraryObject -> A.Object-addKeys u g t (ArbitraryObject o) = o `M.union` M.fromList [ ("user", A.toJSON u)- , ("group", A.toJSON g)- , ("otype", A.toJSON t)- ]--addView :: CouchT IO ()-addView = couchPut_ "_design/dataviews" [] viewObj where- viewObj = A.object - [ "language" .= ("javascript" :: T.Text)- , "views" .= A.object- [ "bytype" .= A.object- [ "map" .= ("function(doc) {\- \ emit([doc.user,doc.group,doc.otype], doc); \- \}" :: T.Text)- ]- ]- ]--queryByType :: Integer -> Integer -> Integer -> Enumerator A.Object (ReaderT CouchConnection IO) b-queryByType u g t = couchView path query $= extractViewValue- where path = "dataviews/_view/bytype"- key = "[" ++ show u ++ "," ++ show g ++ "," ++ show t ++ "]"- query = [(BU8.fromString "key", Just $ BU8.fromString key)]--queryByGroup :: Integer -> Integer -> Enumerator A.Object (ReaderT CouchConnection IO) b-queryByGroup u g = couchView path query $= extractViewValue- where path = "dataviews/_view/bytype"- skey = "[" ++ show u ++ "," ++ show g ++ "]"- ekey = "[" ++ show u ++ "," ++ show g ++ ",{}]"- query = [ (BU8.fromString "startkey", Just $ BU8.fromString skey)- , (BU8.fromString "endkey" , Just $ BU8.fromString ekey)- ]--views :: [ArbitraryObject] -> CouchT IO ()-views lst = do- let (group1,x1) = splitAt 3 lst- (group2,x2) = splitAt 3 x1- (group3,x3) = splitAt 3 x2- (group4,_ ) = splitAt 3 x3-- g1key = map (("view"++) . show) ([0..2] :: [Int])- g1obj = map (addKeys 0 0 0) group1- g2key = map (("view"++) . show) ([5..7] :: [Int])- g2obj = map (addKeys 0 0 1) group2- g3key = map (("view"++) . show) ([10..12] :: [Int])- g3obj = map (addKeys 0 1 0) group3- g4key = map (("view"++) . show) ([15..17] :: [Int])- g4obj = map (addKeys 1 0 0) group4-- mapM_ clearObject $ g1key ++ g2key ++ g3key ++ g4key-- checkError (Just 409) addView-- forM_ (zip g1key g1obj ++ zip g2key g2obj ++ zip g3key g3obj ++ zip g4key g4obj) $ \(k,o) ->- couchPut_ k [] o-- assertViewRet [] $ queryByType 0 0 2- assertViewRet [] $ queryByType 0 2 0- assertViewRet [] $ queryByType 2 0 0-- assertViewRet g1obj $ queryByType 0 0 0- assertViewRet g2obj $ queryByType 0 0 1- assertViewRet g3obj $ queryByType 0 1 0- assertViewRet g4obj $ queryByType 1 0 0-- assertViewRet (g1obj ++ g2obj) $ queryByGroup 0 0- assertViewRet g3obj $ queryByGroup 0 1- assertViewRet g4obj $ queryByGroup 1 0-- assertViewRet [] $ queryByGroup 0 2- assertViewRet [] $ queryByGroup 2 0---- vim: set expandtab:set tabstop=4: