diff --git a/Database/CouchDB/Enumerator.hs b/Database/CouchDB/Enumerator.hs new file mode 100644 --- /dev/null +++ b/Database/CouchDB/Enumerator.hs @@ -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. +-- +-- +-- > {-# 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 +-- 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: diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain diff --git a/couchdb-enumerator.cabal b/couchdb-enumerator.cabal new file mode 100644 --- /dev/null +++ b/couchdb-enumerator.cabal @@ -0,0 +1,78 @@ +Name: couchdb-enumerator +Version: 0.2.0 +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.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 + diff --git a/tests.hs b/tests.hs new file mode 100644 --- /dev/null +++ b/tests.hs @@ -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: