couchdb-enumerator (empty) → 0.2.0
raw patch · 5 files changed
+692/−0 lines, 5 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, attoparsec, attoparsec-enumerator, base, bytestring, containers, enumerator, http-enumerator, http-types, monad-control, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers, utf8-string, vector
Files
- Database/CouchDB/Enumerator.hs +320/−0
- LICENSE +25/−0
- Setup.lhs +8/−0
- couchdb-enumerator.cabal +78/−0
- tests.hs +261/−0
+ Database/CouchDB/Enumerator.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, OverloadedStrings #-}++-- | 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 = withCouchConnection "localhost" 5984 "test" $ runCouchT $ 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:5983/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(..)+ , withCouchConnection+ , CouchError(..)+ , CouchMonad(..)++ -- * Accessing Couch DB+ , Path+ , Revision+ , couchGet+ , couchPut+ , couchPut_+ , couchDelete+ , couchView+ , extractViewValue+ , couch++ -- * A ReaderT CouchMonad+ , CouchT(..)+ , runCouchT+) where++import Control.Applicative+import Control.Exception (Exception, throw, bracket)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Control (MonadControlIO, liftIOOp)+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import qualified Data.Aeson as A+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.Map 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 (pooled) connection to a single Couch DB Dabase.+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.+withCouchConnection :: (MonadControlIO m) => String -- ^ host+ -> Int -- ^ port+ -> String -- ^ database name+ -> (CouchConnection -> m a) -- ^ function to run+ -> m a+withCouchConnection h p db f = liftIOOp (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 couch connection.+class (MonadIO m) => CouchMonad m where+ couchConnection :: m CouchConnection++-- | 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 :: (CouchMonad 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+ -> H.RequestBody m -- ^ body+ -> Iteratee B.ByteString m a+couch m p q i b = Iteratee $ do+ conn <- couchConnection+ let req = H.Request { H.method = m+ , H.secure = False+ , H.checkCerts = const $ return False+ , H.host = host conn+ , H.port = port conn+ , H.path = BU8.fromString ("/" ++ dbname conn ++ "/" ++ p)+ , H.queryString = q+ , H.requestHeaders = []+ , H.requestBody = b+ , H.proxy = Nothing+ , H.rawBody = False+ }+ runIteratee $ H.http req (\s _ -> checkStatus s i) (manager conn)++-- | Load a single object from couch DB.+couchGet :: (CouchMonad 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 :: (CouchMonad 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 = H.RequestBodyLBS $ A.encode $ A.toJSON val++-- | A version of 'couchPut' which ignores the return value. This is slightly faster than / _ <- couchPut .../+-- since the JSON parser is not run.+couchPut_ :: (CouchMonad 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 = H.RequestBodyLBS $ A.encode $ A.toJSON val++-- | Delete the given revision of the object.+couchDelete :: (CouchMonad 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 :: (CouchMonad 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"++-- | ReaderT implementation of CouchMonad.+newtype CouchT m a = CouchT (ReaderT CouchConnection m a)+ deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadControlIO)++instance (MonadIO m) => CouchMonad (CouchT m) where+ couchConnection = CouchT ask++-- | Run a Couch DB backend.+runCouchT :: (Monad m) => CouchT m a -> CouchConnection -> m a+runCouchT (CouchT r) = runReaderT r++-----------------------------------------------------------------------------------------+--- Helper Code+-----------------------------------------------------------------------------------------++-- | 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++-- vim: set expandtab:set tabstop=4:
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2011, John Lenz. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple+> import System.Cmd (system)++> main :: IO ()+> main = defaultMain
+ couchdb-enumerator.cabal view
@@ -0,0 +1,78 @@+Name: couchdb-enumerator+Version: 0.2.0+Cabal-Version: >= 1.8+License: BSD3+License-File: LICENSE+Author: John Lenz <jlenz2@math.uiuc.edu>+Maintainer: John Lenz <jlenz2@math.uiuc.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.3 && < 0.4+ , attoparsec >= 0.8 && < 0.10+ , attoparsec-enumerator >= 0.2 && < 0.3+ , base >= 4 && < 5+ , bytestring >= 0.9 && < 0.10+ , containers >= 0.4 && < 0.5+ , enumerator >= 0.4 && < 0.5+ , http-types >= 0.6 && < 0.7+ , http-enumerator >= 0.6.5.3 && < 0.7+ , monad-control >= 0.2 && < 0.3+ , text >= 0.11 && < 0.12+ , transformers >= 0.2 && < 0.3+ , 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.3 && < 0.4+ , attoparsec >= 0.8 && < 0.10+ , attoparsec-enumerator >= 0.2 && < 0.3+ , base >= 4 && < 5+ , bytestring >= 0.9 && < 0.10+ , containers >= 0.4 && < 0.5+ , enumerator >= 0.4 && < 0.5+ , http-types >= 0.6 && < 0.7+ , http-enumerator >= 0.6.5.3 && < 0.7+ , monad-control >= 0.2 && < 0.3+ , text >= 0.11 && < 0.12+ , transformers >= 0.2 && < 0.3+ , utf8-string >= 0.3 && < 0.4++ , QuickCheck >= 2+ , HUnit+ , test-framework+ , test-framework-quickcheck2+ , test-framework-hunit+ , vector+ else+ Buildable: False+
+ tests.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Prelude hiding (catch)++import Control.Applicative+import Control.Exception.Control (throwIO, catch)+import Control.Monad+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Control (MonadControlIO)+import Control.Monad.Trans.Class (lift)+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 Data.List (nubBy)+import qualified Data.Map 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+----------------------------------------------------------------------------------++testCouch :: (CouchT IO a) -> IO ()+testCouch c = withCouchConnection "www.wuzzeb.org" 5984 "test" (runCouchT 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') = if t == t'+ then return ()+ else assertFailure $ "strings are not equal. expecting " + ++ T.unpack t ++ " received " ++ T.unpack t'+assertStr _ _ = assertFailure "expecting a JSON string"++-- | 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") $ M.member t x+ f $ fromJust $ M.lookup t x++-- | Expect a couch error with the given code+assertRecvError :: (MonadControlIO m) => Maybe Int -> m a -> m ()+assertRecvError code v = go `catch` \(CouchError c _) -> liftIO (code @=? c)+ where go = 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" $ M.isSubmapOf obj obj'++-- | Delete the given object, useful for the start of a test+clearObject :: String -> CouchT IO ()+clearObject n = go `catch` \(e@(CouchError i _)) -> if i == Just 404 then return () else throwIO e+ where go = do obj <- couchGet n []+ when (not $ M.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 "test") v++missingObjectTest :: CouchT IO ()+missingObjectTest = do+ 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) -> do+ 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 (M.isSubmapOf x) lst2 of+ Nothing -> error $ "Unable to find " ++ show (A.encode $ A.Object x)+ Just _ -> checkEqual xs $ deleteBy M.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 (CouchT 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 (CouchT 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++ addView `catch` \e@(CouchError c _) -> if c == Just 409 then return () else throwIO e++ 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: