diff --git a/Database/CouchDB/Enumerator.hs b/Database/CouchDB/Enumerator.hs deleted file mode 100644 --- a/Database/CouchDB/Enumerator.hs +++ /dev/null @@ -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. --- --- --- > {-# 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 --- 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 --- or --- 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: diff --git a/couchdb-enumerator.cabal b/couchdb-enumerator.cabal --- a/couchdb-enumerator.cabal +++ b/couchdb-enumerator.cabal @@ -1,80 +1,86 @@ -Name: couchdb-enumerator -Version: 0.3.4 -Cabal-Version: >= 1.8 -License: BSD3 -License-File: LICENSE -Author: John Lenz -Maintainer: John Lenz -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 +maintainer: John Lenz +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 + diff --git a/src/Database/CouchDB/Enumerator.hs b/src/Database/CouchDB/Enumerator.hs new file mode 100644 --- /dev/null +++ b/src/Database/CouchDB/Enumerator.hs @@ -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. + + +> {-# 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 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 +-- or +-- 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: diff --git a/src/Database/CouchDB/Enumerator/Generic.hs b/src/Database/CouchDB/Enumerator/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Database/CouchDB/Enumerator/Generic.hs @@ -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" diff --git a/test/Database/CouchDB/Enumerator/Test/Basic.hs b/test/Database/CouchDB/Enumerator/Test/Basic.hs new file mode 100644 --- /dev/null +++ b/test/Database/CouchDB/Enumerator/Test/Basic.hs @@ -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" diff --git a/test/Database/CouchDB/Enumerator/Test/Generic.hs b/test/Database/CouchDB/Enumerator/Test/Generic.hs new file mode 100644 --- /dev/null +++ b/test/Database/CouchDB/Enumerator/Test/Generic.hs @@ -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 "И проч" + + + + + + diff --git a/test/Database/CouchDB/Enumerator/Test/Util.hs b/test/Database/CouchDB/Enumerator/Test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Database/CouchDB/Enumerator/Test/Util.hs @@ -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 diff --git a/test/Database/CouchDB/Enumerator/Test/View.hs b/test/Database/CouchDB/Enumerator/Test/View.hs new file mode 100644 --- /dev/null +++ b/test/Database/CouchDB/Enumerator/Test/View.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/tests.hs b/tests.hs deleted file mode 100644 --- a/tests.hs +++ /dev/null @@ -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: