couchdb-conduit (empty) → 0.1.0.0
raw patch · 17 files changed
+1314/−0 lines, 17 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, attoparsec, attoparsec-conduit, base, blaze-builder, bytestring, conduit, containers, couchdb-conduit, data-default, http-conduit, http-types, lifted-base, monad-control, syb, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers, transformers-base, unordered-containers, utf8-string
Files
- LICENSE +25/−0
- Setup.hs +2/−0
- couchdb-conduit.cabal +97/−0
- src/Database/CouchDB/Conduit.hs +175/−0
- src/Database/CouchDB/Conduit/DB.hs +58/−0
- src/Database/CouchDB/Conduit/Explicit.hs +106/−0
- src/Database/CouchDB/Conduit/Generic.hs +96/−0
- src/Database/CouchDB/Conduit/Internal/Doc.hs +120/−0
- src/Database/CouchDB/Conduit/Internal/Parser.hs +43/−0
- src/Database/CouchDB/Conduit/Internal/View.hs +21/−0
- src/Database/CouchDB/Conduit/LowLevel.hs +97/−0
- src/Database/CouchDB/Conduit/View.hs +193/−0
- test/Database/CouchDB/Conduit/Test/Explicit.hs +94/−0
- test/Database/CouchDB/Conduit/Test/Generic.hs +87/−0
- test/Database/CouchDB/Conduit/Test/Util.hs +14/−0
- test/Database/CouchDB/Conduit/Test/View.hs +70/−0
- test/Main.hs +16/−0
+ 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.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ couchdb-conduit.cabal view
@@ -0,0 +1,97 @@+name: couchdb-conduit+version: 0.1.0.0 +cabal-version: >= 1.8+build-type: Simple+stability: Experimental+category: Database, Conduit+license: BSD3+license-file: LICENSE+author: John Lenz <lenz@math.uic.edu>, Alexander Dorofeev <aka.spin@gmail.com>+maintainer: Alexander Dorofeev <aka.spin@gmail.com>+synopsis: Couch DB client library using http-conduit and aeson+homepage: https://github.com/akaspin/couchdb-conduit+bug-reports: https://github.com/akaspin/couchdb-conduit/issues+description: + This package is a thin wrapper around http-conduit to access a Couch DB Database,+ using the aeson package to parse and encode JSON data. http-conduit, 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.+data-files: test/Database/CouchDB/Conduit/Test/Explicit.hs, test/Database/CouchDB/Conduit/Test/Generic.hs, test/Database/CouchDB/Conduit/Test/Util.hs, test/Database/CouchDB/Conduit/Test/View.hs, test/Main.hs ++source-repository head+ type: git+ location: git://github.com/akaspin/couchdb-conduit.git++library+ hs-source-dirs: src+ build-depends: + base >= 4 && < 5,+ conduit >= 0.0.0.2 && < 0.1,+ attoparsec >= 0.8 && < 0.11,+ attoparsec-conduit >= 0.0 && < 0.1,+ http-conduit >= 1.1.0.1 && < 1.2,+ http-types >= 0.6 && < 0.7,+ monad-control >= 0.3 && < 0.4,+ transformers >= 0.2 && < 0.3,+ transformers-base >= 0.4.1 && < 0.5,+ lifted-base >= 0.1 && < 0.2,+ bytestring >= 0.9 && < 0.10,+ utf8-string >= 0.3 && < 0.4,+ aeson >= 0.5 && < 0.6,+ text >= 0.11 && < 0.12,+ unordered-containers >= 0.1 && < 0.2,+ syb,+ containers,+ data-default,+ blaze-builder+ ghc-options: -Wall+ exposed-modules: + Database.CouchDB.Conduit,+ Database.CouchDB.Conduit.DB,+ Database.CouchDB.Conduit.Explicit,+ Database.CouchDB.Conduit.Generic,+ Database.CouchDB.Conduit.LowLevel,+ Database.CouchDB.Conduit.View+ other-modules: + Database.CouchDB.Conduit.Internal.Doc,+ Database.CouchDB.Conduit.Internal.Parser,+ Database.CouchDB.Conduit.Internal.View++test-suite test+ type: exitcode-stdio-1.0+ x-uses-tf: true+ build-depends: + base >= 4,+ HUnit >= 1.2 && < 2,+ QuickCheck >= 2.4,+ test-framework >= 0.4.1,+ test-framework-quickcheck2,+ test-framework-hunit,+ couchdb-conduit,+ conduit >= 0.0.0.2 && < 0.1,+ attoparsec >= 0.8 && < 0.11,+ attoparsec-conduit >= 0.0 && < 0.1,+ http-conduit >= 1.1.0.1 && < 1.2,+ http-types >= 0.6 && < 0.7,+ monad-control >= 0.3 && < 0.4,+ transformers >= 0.2 && < 0.3,+ transformers-base >= 0.4.1 && < 0.5,+ lifted-base >= 0.1 && < 0.2,+ bytestring >= 0.9 && < 0.10,+ utf8-string >= 0.3 && < 0.4,+ aeson >= 0.5 && < 0.6,+ text >= 0.11 && < 0.12,+ unordered-containers >= 0.1 && < 0.2,+ syb,+ containers,+ blaze-builder+ ghc-options: -Wall -rtsopts -threaded + hs-source-dirs: test+ main-is: Main.hs+ other-modules: + Database.CouchDB.Conduit.Test.Explicit,+ Database.CouchDB.Conduit.Test.Util,+ Database.CouchDB.Conduit.Test.View,+ Database.CouchDB.Conduit.Test.Generic+
+ src/Database/CouchDB/Conduit.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +{- | +To work with concrete objects, use the following modules: + + * "Database.CouchDB.Conduit.DB" + + * "Database.CouchDB.Conduit.View" + + * "Database.CouchDB.Conduit.Explicit" + + * "Database.CouchDB.Conduit.Generic" + + * "Database.CouchDB.Conduit.LowLevel" + +For complete documentation about The Couch DB HTTP API see +<http://wiki.apache.org/couchdb/Complete_HTTP_API_Reference> +-} + +module Database.CouchDB.Conduit ( + -- * Document paths and revisions #path# + -- $path + Path, + mkPath, + Revision, + + -- * CouchDB Connection #connection# + CouchConnection, + def, + couchHost, + couchPort, + couchManager, + couchDB, + + -- * Runtime enviroment and errors #runtime# + -- $runtime + MonadCouch (..), + CouchError (..), + runCouch, + withCouchConnection, + +) where + +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Control.Exception (Exception) +import Control.Monad.Trans.Class (lift) + +import Data.Conduit (ResourceIO, ResourceT, runResourceT) + +import qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT + +import Data.Generics (Typeable) +import Data.Default (Default (def)) +import qualified Data.ByteString as B +import qualified Data.Text.Encoding as TE +import qualified Blaze.ByteString.Builder as BLB + +----------------------------------------------------------------------------- +-- Paths +----------------------------------------------------------------------------- + +-- $path +-- As a rule, full path to document in CouchDB is just URL path. But there is +-- one subtlety. For example, document ids /can/ contain slashes. But, +-- to work with such objects, path fragments must be escaped. +-- +-- > database/doc%2Fname +-- +-- But, fo non-document items such as views, attachments e.t.c., slashes +-- between path fragments /must not/ be escaped. While slashes in path +-- fragments /must/ be escaped. +-- +-- > database/_design/my%2Fdesign/_view/my%2Fview + +-- | Represents a path or path fragment. +type Path = B.ByteString + +-- | Represents a revision of a CouchDB Document. +type Revision = B.ByteString + +-- | Make correct path from escaped fragments. Filter empty fragments. +-- +-- > mkPath ["db", "", "doc/with/slashes"] +-- > db/doc%2Fwith%2Fslashes +mkPath :: [Path] -- ^ Path fragments be escaped. + -> Path +mkPath = BLB.toByteString . HT.encodePathSegments . + map TE.decodeUtf8 . filter (/="") + +----------------------------------------------------------------------------- +-- Connection +----------------------------------------------------------------------------- + +-- | Represents a single connection to CouchDB server. The constructor for this +-- data type is not exposed. Instead, you should use either the 'def' method +-- to retrieve a default instance. +data CouchConnection = CouchConnection { + couchHost :: B.ByteString + -- ^ Hostname. Default value is \"localhost\" + , couchPort :: Int + -- ^ Port. 5984 by default. + , couchManager :: Maybe H.Manager + -- ^ Connection 'Manager'. 'Nothing' by default. If you need to use + -- your 'H.Manager' (for connection pooling for example), set it to + -- 'Just' 'H.Manager'. + , couchDB :: Path + -- ^ Database name. This value is prepended to 'Path' to form the full + -- path in all requests. + -- + -- By default is 'B.empty'. This makes it possible to access + -- different databases through a single connection. But, in this + -- case, all requests must be preceded by the database name with + -- unescaped slash. See 'Path' for details. +} + +instance Default CouchConnection where + def = CouchConnection "localhost" 5984 Nothing B.empty + +----------------------------------------------------------------------------- +-- Runtime +----------------------------------------------------------------------------- + +-- $runtime +-- All functions 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' and 'ResourceT'. +-- +-- 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. + +-- | A monad which allows access to the connection. +class ResourceIO m => MonadCouch m where + couchConnection :: m CouchConnection + +instance (ResourceIO m) => MonadCouch (ReaderT CouchConnection m) where + couchConnection = ask + +-- | 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 + +-- | Run a sequence of CouchDB actions. This function is a combination of +-- 'withCouchConnection', 'runReaderT' and 'runResourceT'. +-- +-- If you create your own instance of 'MonadCouch', use 'withCouchConnection'. +runCouch :: ResourceIO m => + CouchConnection -- ^ Couch connection + -> ResourceT (ReaderT CouchConnection m) a -- ^ CouchDB actions + -> m a +runCouch c = withCouchConnection c . runReaderT . runResourceT + +-- | Connect to a CouchDB server, call the supplied function, and then close +-- the connection. +-- +-- > withCouchConnection def {couchDB = "db"} . runReaderT . runResourceT $ do +-- > ... -- actions +withCouchConnection :: ResourceIO m => + CouchConnection -- ^ Couch connection + -> (CouchConnection -> m a) -- ^ Function to run + -> m a +withCouchConnection c@(CouchConnection _ _ mayMan _) f = + case mayMan of + Nothing -> H.withManager $ \m -> lift $ f $ c {couchManager = Just m} + Just m -> runResourceT $ lift $ f $ c {couchManager = Just m} +
+ src/Database/CouchDB/Conduit/DB.hs view
@@ -0,0 +1,58 @@+{- | CouchDB database methods. + +/Note about paths./ If you passed a database name to +"Database.CouchDB.Conduit#connection", the path in methods below should be the +'B.empty'. But, if you passed the 'B.empty' to 'CouchConnection', then the +@couchDB@ should be used in these methods. + +> runCouch def $ couchPutDb "my_new_db" +> runCouch def {couchDB="another_new_db"} $ couchPutDb "" +-} + +module Database.CouchDB.Conduit.DB ( + -- * Methods + couchPutDB, + couchPutDB', + couchDeleteDB +) where + +import Prelude hiding (catch) +import Control.Exception.Lifted (catch) + +import qualified Data.ByteString as B + +import Data.Conduit (ResourceT, resourceThrow) + +import qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT + +import Database.CouchDB.Conduit (MonadCouch(..), CouchError(..), Path) +import Database.CouchDB.Conduit.LowLevel (couch, protect') +import Control.Monad.Trans.Class (lift)+ +-- | Create CouchDB database. +couchPutDB :: MonadCouch m => + Path -- ^ CouchDB Database name. See note above. + -> ResourceT m () +couchPutDB p = couch HT.methodPut p [] [] + (H.RequestBodyBS B.empty) protect' + >> return () + +-- | Brute force version of couchPutDb. Create CouchDB database regardless +-- of presence. Catches 'CouchError' @412@. +couchPutDB' :: MonadCouch m => + Path -- ^ CouchDB Database name. See note above. + -> ResourceT m () +couchPutDB' p = + catch (couchPutDB p) handler + where + handler (CouchError (Just 412) _) = return () + handler e = lift $ resourceThrow e + +-- | Delete a database. +couchDeleteDB :: MonadCouch m => + Path -- ^ CouchDB Database name. See note above. + -> ResourceT m () +couchDeleteDB p = couch HT.methodDelete p [] [] + (H.RequestBodyBS B.empty) protect' + >> return ()
+ src/Database/CouchDB/Conduit/Explicit.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} + +-- | Explicit methods for CouchDB documents. Documents represents in \"good +-- old\" aeson manner through 'A.ToJSON' and 'A.FromJSON'. +-- +-- > {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +-- > +-- > import Control.Applicative ((<$>), (<*>)) +-- > import Control.Monad.IO.Class (liftIO) +-- > import Data.Aeson +-- > import Database.CouchDB.Conduit +-- > import Database.CouchDB.Conduit.Explicit +-- > +-- > -- | Our doc with instances +-- > data D = D { f1 :: Int, f2 :: String } deriving (Show) +-- > +-- > instance FromJSON D where +-- > parseJSON (Object v) = D <$> v .: "f1" <*> v .: "f2" +-- > parseJSON _ = mzero +-- > +-- > instance ToJSON D where +-- > toJSON (D f1 f2) = object ["f1" .= f1, "f2" .= f2] +-- > +-- > runCouch def {couchDB="mydb"} $ do +-- > -- Put new doc and update it +-- > rev1 <- couchPut "my-doc1" "" [] $ D 123 "str" +-- > rev2 <- couchPut "my-doc1" rev1 [] $ D 1234 "another" +-- > +-- > -- get it and print +-- > (rev3, d1 :: D) <- couchGet "my-doc1" [] +-- > liftIO $ print d1 +-- > +-- > -- update it in brute-force manner +-- > couchPut' "my-doc1" [] $ D 12345 "third" -- notice - no rev +-- > +-- > -- get revision and delete +-- > rev3 <- couchRev "my-doc1" +-- > couchDelete "my-doc1" rev3 +-- +-- For details of types see "Data.Aeson". To work with documents in +-- generic manner, look at "Database.CouchDB.Conduit.Generic". + +module Database.CouchDB.Conduit.Explicit ( + -- * Accessing documents + couchGet, + couchRev, + -- * Manipulating documents + couchPut, + couchPut', + couchDelete, + -- * Working with views #view# + toType +) where + +import qualified Data.Aeson as A +import Data.Conduit (ResourceT, Conduit(..), ResourceIO) + +import Network.HTTP.Types as HT + +import Database.CouchDB.Conduit (MonadCouch(..), Path, Revision) +import Database.CouchDB.Conduit.Internal.Doc (couchRev, + couchDelete, couchGetWith, couchPutWith, couchPutWith') +import Database.CouchDB.Conduit.Internal.View (toTypeWith) + +------------------------------------------------------------------------------ +-- Document +------------------------------------------------------------------------------ + +-- | Load a single 'A.ToJSON' object with 'Revision' from couch DB. +couchGet :: (MonadCouch m, A.FromJSON a) => + Path -- ^ Document path + -> HT.Query -- ^ Query + -> ResourceT m (Revision, a) +couchGet = couchGetWith A.fromJSON + +-- | Put an 'A.FromJSON' object in Couch DB with revision, returning the +-- new 'Revision'. +couchPut :: (MonadCouch m, A.ToJSON a) => + Path -- ^ Document path. + -> Revision -- ^ Document revision. For new docs provide empty string. + -> HT.Query -- ^ Query arguments. + -> a -- ^ The object to store. + -> ResourceT m Revision +couchPut = couchPutWith A.encode + +-- | Brute force version of 'couchPut'. +couchPut' :: (MonadCouch m, A.ToJSON a) => + Path -- ^ Document path. + -> HT.Query -- ^ Query arguments. + -> a -- ^ The object to store. + -> ResourceT m Revision +couchPut' = couchPutWith' A.encode + +------------------------------------------------------------------------------ +-- View conduit +------------------------------------------------------------------------------ + +-- | Convert CouchDB view row or row value from "Database.CouchDB.Conduit.View" +-- to concrete 'A.FromJSON' type. +-- +-- > res <- couchView "mydesign" "myview" [] $ rowValue =$= toType =$ consume +toType :: (ResourceIO m, A.FromJSON a) => Conduit A.Value m a +toType = toTypeWith A.fromJSON + + +
+ src/Database/CouchDB/Conduit/Generic.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} + +-- | Generic methods for CouchDB documents. Unlike explicit, generic methods +-- uses "Data.Generic". +-- +-- > {-# LANGUAGE DeriveDataTypeable #-} +-- > {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +-- > +-- > import Control.Monad.IO.Class (liftIO) +-- > import Data.Generic (Data, Typeable) +-- > import Database.CouchDB.Conduit +-- > import Database.CouchDB.Conduit.Generic +-- > +-- > -- | Our doc with instances +-- > data D = D { f1 :: Int, f2 :: String } deriving (Show, Data, Typeable) +-- > +-- > runCouch def {couchDB="mydb"} $ do +-- > -- Put new doc and update it +-- > rev1 <- couchPut "my-doc1" "" [] $ D 123 "str" +-- > rev2 <- couchPut "my-doc1" rev1 [] $ D 1234 "another" +-- > +-- > -- get it and print +-- > (rev3, d1 :: D) <- couchGet "my-doc1" [] +-- > liftIO $ print d1 +-- > +-- > -- update it in brute-force manner +-- > couchPut' "my-doc1" [] $ D 12345 "third" -- notice - no rev +-- > +-- > -- get revision and delete +-- > rev3 <- couchRev "my-doc1" +-- > couchDelete "my-doc1" rev3 +-- +-- The main advantage of this approach in the absence of tonns of +-- boilerplate code. The main disadvantage is inability to influence the +-- process of translation to and from JSON. +-- +-- For details of types see "Data.Aeson.Generic". To work with documents in +-- explicit manner, look at "Database.CouchDB.Conduit.Explicit". + +module Database.CouchDB.Conduit.Generic ( + -- * Accessing documents + couchGet, + couchRev, + -- * Manipulating documents + couchPut, + couchPut', + couchDelete, + -- * Working with views #view# + toType +) where + +import Data.Generics (Data) +import qualified Data.Aeson as A +import qualified Data.Aeson.Generic as AG +import Data.Conduit (ResourceT, Conduit(..), ResourceIO) + +import qualified Network.HTTP.Types as HT + +import Database.CouchDB.Conduit +import Database.CouchDB.Conduit.Internal.Doc +import Database.CouchDB.Conduit.Internal.View + +-- | Load a single object from couch DB. +couchGet :: (MonadCouch m, Data a) => + Path -- ^ Document path + -> HT.Query -- ^ Query + -> ResourceT m (Revision, a) +couchGet = couchGetWith AG.fromJSON + +-- | Put an object in Couch DB with revision, returning the new Revision. +couchPut :: (MonadCouch m, Data a) => + Path -- ^ Document path. + -> Revision -- ^ Document revision. For new docs provide empty string. + -> HT.Query -- ^ Query arguments. + -> a -- ^ The object to store. + -> ResourceT m Revision +couchPut = couchPutWith AG.encode + +-- | Brute force version of 'couchPut'. +couchPut' :: (MonadCouch m, Data a) => + Path -- ^ Document path. + -> HT.Query -- ^ Query arguments. + -> a -- ^ The object to store. + -> ResourceT m Revision +couchPut' = couchPutWith' AG.encode + +------------------------------------------------------------------------------ +-- View conduit +------------------------------------------------------------------------------ + +-- | Convert CouchDB view row or row value from 'Database.CouchDB.Conduit.View' +-- to concrete type. +-- +-- > res <- couchView "mydesign" "myview" [] $ rowValue =$= toType =$ consume +toType :: (ResourceIO m, Data a) => Conduit A.Value m a +toType = toTypeWith AG.fromJSON
+ src/Database/CouchDB/Conduit/Internal/Doc.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-} + +-- | Internal +module Database.CouchDB.Conduit.Internal.Doc ( + couchRev, + couchDelete, + couchGetRaw, + + couchGetWith, + couchPutWith, + couchPutWith' +) where + +import Prelude hiding (catch) +import Control.Exception.Lifted (catch) +import Control.Monad.Trans.Class (lift) +import Data.Maybe (fromJust) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Encoding as TE +import qualified Data.Aeson as A +import Data.Conduit (ResourceT, resourceThrow, ($$)) +import qualified Data.Conduit.Attoparsec as CA +import qualified Network.HTTP.Conduit as H +import Network.HTTP.Types as HT + +import Database.CouchDB.Conduit +import Database.CouchDB.Conduit.LowLevel (couch, protect') +import Database.CouchDB.Conduit.Internal.Parser + +------------------------------------------------------------------------------ +-- Type-independent methods +------------------------------------------------------------------------------ + +-- | Get Revision of a document. +couchRev :: MonadCouch m => + Path + -> ResourceT m Revision +couchRev p = do + (H.Response _ hs _) <- couch HT.methodHead p [] [] + (H.RequestBodyBS B.empty) + protect' + return $ peekRev hs + where + peekRev = B.tail . B.init . fromJust . lookup "Etag" + +-- | Delete the given revision of the object. +couchDelete :: MonadCouch m => + Path + -> Revision + -> ResourceT m () +couchDelete p r = couch HT.methodDelete p + [] [("rev", Just r)] + (H.RequestBodyBS B.empty) + protect' >> return () + +------------------------------------------------------------------------------ +-- low-level +------------------------------------------------------------------------------ + +-- | Load raw 'A.Value' from single object from couch DB. +couchGetRaw :: MonadCouch m => + Path -- ^ Document path + -> HT.Query -- ^ Query + -> ResourceT m A.Value +couchGetRaw p q = do + H.Response _ _ bsrc <- couch HT.methodGet p [] q + (H.RequestBodyBS B.empty) protect' + bsrc $$ CA.sinkParser A.json + +------------------------------------------------------------------------------ +-- with converter +------------------------------------------------------------------------------ + +-- | Load CouchDB document and parse it with given parser +couchGetWith :: MonadCouch m =>+ (A.Value -> A.Result a) -- ^ Parser + -> Path -- ^ Path + -> Query -- ^ Query + -> ResourceT m (Revision, a) +couchGetWith f p q = do + H.Response _ _ bsrc <- couch HT.methodGet p [] q + (H.RequestBodyBS B.empty) protect' + j <- bsrc $$ CA.sinkParser A.json + A.String r <- lift $ extractField "_rev" j + o <- lift $ jsonToTypeWith f j + return (TE.encodeUtf8 r, o) + +-- | Put document, with given encoder +couchPutWith :: MonadCouch m =>+ (a -> BL.ByteString) -- ^ Encoder+ -> Path -- ^ Document path. + -> Revision -- ^ Document revision. For new docs provide + -- ^ empty string. + -> Query -- ^ Query arguments.+ -> a -- ^ The object to store.+ -> ResourceT m Revision+couchPutWith f p r q val = do + H.Response _ _ bsrc <- couch HT.methodPut p (ifMatch r) q + (H.RequestBodyLBS $ f val) protect' + j <- bsrc $$ CA.sinkParser A.json + lift $ extractRev j + where + ifMatch "" = [] + ifMatch rv = [("If-Match", rv)] + +-- | Brute force version of 'couchPutWith'. +couchPutWith' :: MonadCouch m => + (a -> BL.ByteString) -- ^ Encoder + -> Path -- ^ Document path. + -> HT.Query -- ^ Query arguments. + -> a -- ^ The object to store. + -> ResourceT m Revision +couchPutWith' f p q val = do + rev <- catch (couchRev p) handler404 + couchPutWith f p rev q val + where + handler404 (CouchError (Just 404) _) = return "" + handler404 e = lift $ resourceThrow e +
+ src/Database/CouchDB/Conduit/Internal/Parser.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-} + +module Database.CouchDB.Conduit.Internal.Parser where + +import Data.Conduit +import qualified Data.ByteString.UTF8 as BU8 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.HashMap.Lazy as M +import qualified Data.Aeson as A + +import Database.CouchDB.Conduit + +--valToRev :: A.Value -> Either CouchError Revision +--valToRev (A.Object o) = case M.lookup "rev" o of +-- (Just (A.String r)) -> Right $ TE.encodeUtf8 r +-- _ -> Left $ CouchError Nothing "unable to find revision" +--valToRev _ = Left $ CouchError Nothing "Couch DB did not return an object" + +extractRev :: ResourceIO m => A.Value -> m Revision +extractRev o = do + A.String r <- extractField "rev" o + return $ TE.encodeUtf8 r + +-- | Extract single field +extractField :: ResourceIO m =>+ T.Text -> A.Value -> m A.Value +extractField s (A.Object o) = case M.lookup s o of + (Just r) -> return r + _ -> resourceThrow $ CouchError Nothing $ + "unable to find field" ++ (BU8.toString . TE.encodeUtf8 $ s) +extractField _ _ = resourceThrow $ CouchError Nothing + "Couch DB did not return an object" + +-- | Convert to type with given convertor +jsonToTypeWith :: ResourceIO m =>+ (A.Value -> A.Result a) + -> A.Value + -> m a +jsonToTypeWith f j = case f j of + A.Error e -> resourceThrow $ CouchError Nothing + ("Error parsing json: " ++ e) + A.Success o -> return o
+ src/Database/CouchDB/Conduit/Internal/View.hs view
@@ -0,0 +1,21 @@+ +module Database.CouchDB.Conduit.Internal.View where + +import qualified Data.Aeson as A +import Data.Conduit (resourceThrow, Conduit(..), ResourceIO) +import qualified Data.Conduit.List as CL (mapM) + + +import Database.CouchDB.Conduit + +-- | Convert CouchDB view row or row value from 'Database.CouchDB.Conduit.View' +-- to concrete type. +-- +-- > res <- couchView "mydesign" "myview" [] $ rowValue =$= toType =$ consume +toTypeWith :: ResourceIO m => + (A.Value -> A.Result a) -- ^ Parser + -> Conduit A.Value m a +toTypeWith f = CL.mapM (\v -> case f v of + A.Error e -> resourceThrow $ CouchError Nothing + ("Error parsing json: " ++ e) + A.Success o -> return o)
+ src/Database/CouchDB/Conduit/LowLevel.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Low-level method and tools of accessing CouchDB. + +module Database.CouchDB.Conduit.LowLevel ( + CouchResponse, + couch, + protect, + protect' +) where + +import Prelude hiding (catch) +import Control.Exception.Lifted (catch) + +import Control.Exception (SomeException) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Base (liftBase) + +import Data.Maybe (fromJust) +import qualified Data.ByteString as B +import Data.Aeson (json, Value(..)) +import qualified Data.ByteString.UTF8 as BU8 +import qualified Data.HashMap.Lazy as M +import qualified Data.Text as T + +import Data.Conduit (ResourceT, BufferedSource, + ($$), resourceThrow) +import Data.Conduit.Attoparsec (sinkParser) + +import qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT + +import Database.CouchDB.Conduit + +-- | CouchDB response +type CouchResponse m = H.Response (BufferedSource m B.ByteString) + +-- | 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 -- ^ Path + -> HT.RequestHeaders -- ^ Headers + -> HT.Query -- ^ Query args + -> H.RequestBody m -- ^ Request body + -> (CouchResponse m -> ResourceT m (CouchResponse m)) + -- ^ Protect function. See 'protect' + -> ResourceT m (CouchResponse m) +couch meth path hdrs qs reqBody protectFn = do + conn <- lift couchConnection + let req = H.def + { H.method = meth + , H.host = couchHost conn + , H.requestHeaders = hdrs + , H.port = couchPort conn + , H.path = B.intercalate "/" . filter (/="") $ + [couchDB conn, path] + , H.queryString = HT.renderQuery False qs + , H.requestBody = reqBody + , H.checkStatus = const . const $ Nothing } + -- FIXME fromMaybe + res <- H.http req (fromJust $ couchManager conn) + protectFn res + +-- | Protect 'H.Response' from bad status codes. If status code in list +-- of status codes - just return response. Otherwise - throw 'CouchError'. +-- +-- Instead 'H.checkStatus', 'protect' parses CouchDB response body JSON and +-- extract \"reason\" message. +-- +-- To protect from typical errors use 'protect''. +protect :: MonadCouch m => + [Int] -- ^ Good codes + -> CouchResponse m -- ^ Response + -> ResourceT m (CouchResponse m) +protect goodCodes ~resp@(H.Response (HT.Status sc sm) _ bsrc) + | sc `elem` goodCodes = return resp + | otherwise = do + v <- catch (bsrc $$ sinkParser json) + (\(_::SomeException) -> return Null) + liftBase $ resourceThrow $ CouchError (Just sc) $ msg v + where + msg v = BU8.toString sm ++ reason v + reason (Object v) = case M.lookup "reason" v of + Just (String t) -> ": " ++ T.unpack t + _ -> "" + reason _ = [] + +-- | Protect from typical status codes: 200, 201, 202 and 304. See 'protect' +-- fo details. +protect' :: MonadCouch m => + CouchResponse m -- ^ Response + -> ResourceT m (CouchResponse m) +protect' = protect [200, 201, 202, 304]
+ src/Database/CouchDB/Conduit/View.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} + +-- | Higher-level functions to interact with CouchDB views. + +module Database.CouchDB.Conduit.View +( + -- * Acccessing views #run# + -- $run + couchView, + couchView', + rowValue, + -- * Manipulating views + couchViewPut +) + where + +import Prelude hiding (catch) +import Control.Exception.Lifted (catch) + +import Control.Monad.Trans.Class (lift) +import Control.Applicative ((<|>)) + +import Data.Default +import Data.Generics (Data, Typeable) +import qualified Data.Map as Map +import qualified Data.ByteString as B +import qualified Data.HashMap.Lazy as M +import qualified Data.Aeson as A +import Data.Attoparsec + +import Data.Conduit +import qualified Data.Conduit.List as CL +import qualified Data.Conduit.Attoparsec as CA + +import qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT + +import Database.CouchDB.Conduit +import Database.CouchDB.Conduit.LowLevel (couch, protect') +import qualified Database.CouchDB.Conduit.Generic as CCG + +----------------------------------------------------------------------------- +-- Running +----------------------------------------------------------------------------- + +-- $run +-- In contrast to the functions of access to documents that are loaded into +-- memory entirely. 'couchView' and 'couchView'' combines the incredible power +-- of /http-conduit/ 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 row, it sent to 'Sink'. 'Sink' can be composed +-- from many conduits with sink at the end, such as 'rowValue', view conduits +-- from "Database.CouchDB.Conduit.Explicit#view" and +-- "Database.CouchDB.Conduit.Generic#view", and many others. See +-- "Data.Conduit" for details and documentation. + +-- | Run CouchDB view in manner like 'H.http'. +-- +-- > runCouch def {couchDB="mydb"} $ do +-- >+-- > -- Print all upon receipt. +-- > src <- couchView "mydesign" "myview" [] +-- > src $$ CL.mapM_ (liftIO . print) +-- > +-- > -- ... Or extract row value and consume +-- > src' <- couchView "mydesign" "myview" [] +-- > res <- src' $= rowValue $$ CL.consume +couchView :: MonadCouch m => + Path -- ^ Design document + -> Path -- ^ View name+ -> HT.Query -- ^ Query parameters+ -> ResourceT m (Source m A.Object)+couchView designDocName viewName q = do + H.Response _ _ bsrc <- couch HT.methodGet fullPath [] q + (H.RequestBodyBS B.empty) protect' + return $ bsrc $= conduitCouchView + where + fullPath = B.concat ["_design/", designDocName, "/_view/", viewName] + +-- | Brain-free version of 'runCouch'. Takes 'Sink' to consume response.+-- +-- > runCouch def {couchDB="mydb"} $ do +-- >+-- > -- Print all upon receipt. +-- > couchView' "mydesign" "myview" [] $ CL.mapM_ (liftIO . print) +-- > +-- > -- ... Or extract row value and consume +-- > res <- couchView' "mydesign" "myview" [] $ rowValue =$ CL.consume+couchView' :: MonadCouch m => + Path -- ^ Design document+ -> Path -- ^ View name+ -> HT.Query -- ^ Query parameters+ -> Sink A.Object m a -- ^ Sink for handle view rows. + -> ResourceT m a +couchView' designDocName viewName q sink = do + H.Response _ _ bsrc <- couch HT.methodGet fullPath [] q + (H.RequestBodyBS B.empty) protect' + bsrc $= conduitCouchView $$ sink + where + fullPath = B.concat ["_design/", designDocName, "/_view/", viewName] + +-- | Conduit for extract \"value\" field from CouchDB view row. +rowValue :: ResourceIO m => Conduit A.Object m A.Value +rowValue = CL.mapM (\v -> case M.lookup "value" v of + (Just o) -> return o + _ -> resourceThrow $ CouchError Nothing $ + "View row does not contain value: " ++ show v) + +----------------------------------------------------------------------------- +-- Manipulators +----------------------------------------------------------------------------- + +-- | View. Just for internal. +data CouchDesignDoc = CouchDesignDoc { + language :: B.ByteString + , views :: Map.Map B.ByteString (Map.Map B.ByteString B.ByteString) + } deriving (Show, Eq, Data, Typeable) + +instance Default CouchDesignDoc where + def = CouchDesignDoc { language = "javascript" , + views = Map.empty } + +-- | Helper for put new views in design documents. +-- +-- /Cauntion/ Current implementation kill all other info except views. Use +-- wise. +couchViewPut :: MonadCouch m => + Path -- ^ Design document + -> Path -- ^ View name + -> B.ByteString -- ^ Language. \"javascript\" for example. + -> B.ByteString -- ^ + -> Maybe B.ByteString + -> ResourceT m Revision +couchViewPut designDocName viewName lang mapFn reduceFn = do + (rev, dd@(CouchDesignDoc l vs)) <- catch + (CCG.couchGet fullPath []) + (\(_ :: CouchError) -> return (B.empty, def)) + if lang /= l then lift $ resourceThrow $ CouchError Nothing "Wrong language" + else CCG.couchPut fullPath rev [] $ + dd { views = Map.insert viewName constructView vs} + where + fullPath = B.concat ["_design/", designDocName] + constructView = let s = Map.singleton "map" mapFn in + maybe s (\f -> Map.insert "reduce" f s) reduceFn + + +----------------------------------------------------------------------------- +-- Internal Parser conduit +----------------------------------------------------------------------------- + +conduitCouchView :: ResourceIO m => Conduit B.ByteString m A.Object +conduitCouchView = sequenceSink () $ \() -> do + b <- CA.sinkParser viewStart + if b then return $ StartConduit viewLoop + else return Stop + +viewLoop :: ResourceIO m => Conduit B.ByteString m A.Object +viewLoop = sequenceSink False $ \isLast -> + if isLast then return Stop + else do + v <- CA.sinkParser (A.json <?> "json object") + vobj <- case v of + (A.Object o) -> return o + _ -> lift $ resourceThrow $ + CouchError Nothing "view entry is not an object" + res <- CA.sinkParser (commaOrClose <?> "comma or close") + case res of + Comma -> return $ Emit False [vobj] + CloseBracket -> return $ Emit True [vobj] + +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 + +-- determine view +viewStart :: Parser Bool +viewStart = do + _ <- string "{" + _ <- option "" $ string "\"total_rows\":" + option () $ skipWhile (\x -> x >= 48 && x <= 57) + _ <- option "" $ string ",\"offset\":" + option () $ skipWhile (\x -> x >= 48 && x <= 57) + _ <- option "" $ string "," + _ <- string "\"rows\":[" + (string "]}" >> return False) <|> return True
+ test/Database/CouchDB/Conduit/Test/Explicit.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +module Database.CouchDB.Conduit.Test.Explicit (tests) where + +import Test.Framework (testGroup, mutuallyExclusive, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) +import Database.CouchDB.Conduit.Test.Util + +import Control.Exception.Lifted (bracket_) +import Control.Monad.IO.Class (liftIO) +import Control.Applicative ((<$>), (<*>), empty) + +import Data.ByteString (ByteString) +import Data.Aeson +import Data.ByteString.UTF8 (fromString) +import Database.CouchDB.Conduit +import Database.CouchDB.Conduit.Explicit + +tests :: Test +tests = mutuallyExclusive $ testGroup "Explicit" [ + testCase "Just put-get-delete" case_justPutGet, + testCase "Mass flow" case_massFlow, + testCase "Mass Iter" case_massIter + ] + +data TestDoc = TestDoc { kind :: String, intV :: Int, strV :: String } + deriving (Show, Eq) + +instance FromJSON TestDoc where + parseJSON (Object v) = TestDoc <$> v .: "kind" <*> v .: "intV" <*> v .: "strV" + parseJSON _ = empty + +instance ToJSON TestDoc where + toJSON (TestDoc k i s) = object ["kind" .= k, "intV" .= i, "strV" .= s] + +case_justPutGet :: Assertion +case_justPutGet = bracket_ + setup teardown $ + runCouch conn $ do + rev <- couchPut "doc-just" "" [] $ TestDoc "doc" 1 "1" + rev' <- couchPut "doc-just" rev [] $ TestDoc "doc" 2 "2" + rev'' <- couchRev "doc-just" + liftIO $ rev' @=? rev'' + couchDelete "doc-just" rev'' + +case_massFlow :: Assertion +case_massFlow = bracket_ + setup teardown $ + runCouch conn $ do + revs <- mapM (\n -> + couchPut (docn n) "" [] $ TestDoc "doc" n $ show n + ) [1..100] + liftIO $ length revs @=? 100 + revs' <- mapM (\n -> + couchRev $ docn n) [1..100] + liftIO $ revs @=? revs' + liftIO $ length revs' @=? 100 + mapM_ (\(n,r) -> + couchDelete (docn n) r) $ zip [1..100] revs' + where + docn n = fromString $ "doc-" ++ show (n :: Int) + + +case_massIter :: Assertion +case_massIter = bracket_ + setup teardown $ + runCouch conn $ + mapM_ (\n -> do + let name = docn n + let d = TestDoc "doc" n $ show n + rev <- couchPut name "" [] d + couchDelete (docn n) rev + _ <- couchPut name "" [] d + rev'' <- couchPut' name [] d + (_, d') <- couchGet name [] + liftIO $ d @=? d' + couchDelete (docn n) rev'' + ) [1..100] + where + docn n = fromString $ "doc-" ++ show (n :: Int) + +setup :: IO () +setup = setupDB dbName +teardown :: IO () +teardown = tearDB dbName + +conn :: CouchConnection +conn = def {couchDB = dbName} + +dbName :: ByteString +dbName = "cdbc_test_explicit"
+ test/Database/CouchDB/Conduit/Test/Generic.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} + +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +module Database.CouchDB.Conduit.Test.Generic (tests) where + +import Test.Framework (testGroup, mutuallyExclusive, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) +import Database.CouchDB.Conduit.Test.Util + +import Control.Exception.Lifted (bracket_) +import Control.Monad.IO.Class (liftIO) + +import Data.ByteString (ByteString) +import Data.Generics (Data, Typeable) +import Data.ByteString.UTF8 (fromString) +import Database.CouchDB.Conduit +import Database.CouchDB.Conduit.Generic + +tests :: Test +tests = mutuallyExclusive $ testGroup "Generic" [ + testCase "Just put-get-delete" case_justPutGet, + testCase "Mass flow" case_massFlow, + testCase "Mass Iter" case_massIter + ] + +data TestDoc = TestDoc { kind :: String, intV :: Int, strV :: String } + deriving (Show, Eq, Data, Typeable) + +case_justPutGet :: Assertion +case_justPutGet = bracket_ + setup teardown $ + runCouch conn $ do + rev <- couchPut "doc-just" "" [] $ TestDoc "doc" 1 "1" + rev' <- couchPut "doc-just" rev [] $ TestDoc "doc" 2 "2" + rev'' <- couchRev "doc-just" + liftIO $ rev' @=? rev'' + couchDelete "doc-just" rev'' + +case_massFlow :: Assertion +case_massFlow = bracket_ + setup teardown $ + runCouch conn $ do + revs <- mapM (\n -> + couchPut (docn n) "" [] $ TestDoc "doc" n $ show n + ) [1..100] + liftIO $ length revs @=? 100 + revs' <- mapM (\n -> + couchRev $ docn n) [1..100] + liftIO $ revs @=? revs' + liftIO $ length revs' @=? 100 + mapM_ (\(n,r) -> + couchDelete (docn n) r) $ zip [1..100] revs' + where + docn n = fromString $ "doc-" ++ show (n :: Int) + + +case_massIter :: Assertion +case_massIter = bracket_ + setup teardown $ + runCouch conn $ + mapM_ (\n -> do + let name = docn n + let d = TestDoc "doc" n $ show n + rev <- couchPut name "" [] d + couchDelete (docn n) rev + _ <- couchPut name "" [] d + rev'' <- couchPut' name [] d + (_, d') <- couchGet name [] + liftIO $ d @=? d' + couchDelete (docn n) rev'' + ) [1..100] + where + docn n = fromString $ "doc-" ++ show (n :: Int) + +setup :: IO () +setup = setupDB dbName +teardown :: IO () +teardown = tearDB dbName + +conn :: CouchConnection +conn = def {couchDB = dbName} + +dbName :: ByteString +dbName = "cdbc_test_generic"
+ test/Database/CouchDB/Conduit/Test/Util.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-} + +module Database.CouchDB.Conduit.Test.Util where + +import Data.ByteString + +import Database.CouchDB.Conduit +import Database.CouchDB.Conduit.DB + +setupDB :: ByteString -> IO () +setupDB n = runCouch def {couchDB = n} $ couchPutDB "" + +tearDB :: ByteString -> IO () +tearDB n = runCouch def {couchDB = n} $ couchDeleteDB ""
+ test/Database/CouchDB/Conduit/Test/View.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Database.CouchDB.Conduit.Test.View where + +import Test.Framework (testGroup, mutuallyExclusive, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion) + +--import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (liftIO) + +import Data.Generics (Data, Typeable) +import Data.Conduit +import qualified Data.Conduit.List as CL + +import Database.CouchDB.Conduit +import Database.CouchDB.Conduit.View +import Control.Monad.Trans.Reader (runReaderT)+ +tests :: Test +tests = mutuallyExclusive $ testGroup "View" [ + testCase "Basic" case_basicViewM +-- testCase "Basic" case_basicView, +-- testCase "Basic with reduce" case_basicViewReduce + ] + +data T = T { + kind :: String, + intV :: Int, + strV :: String + } deriving (Show, Eq, Data, Typeable) + +case_manip :: Assertion +case_manip = runCouch conn $ do + r' <- couchViewPut "test" "group3" "javascript" + "function(doc) {emit(null, doc);}" Nothing + r'' <- couchViewPut "test1" "group3" "javascript" + "function(doc) {emit(null, doc);}" Nothing + liftIO $ print (r', r'') + +case_basicViewM :: Assertion +case_basicViewM = withCouchConnection conn . runReaderT . runResourceT $ do + s <- couchView "test" "group1" [("reduce", Just "false")] + _ <- s $= (CL.mapM (liftIO . print)) $$ CL.consume + s' <- couchView "test" "group1" [("reduce", Just "false")] + _ <- s' $= rowValue $$ CL.mapM_ (liftIO . print) + res' <- couchView' "test" "group1" [("reduce", Just "false")] $ + rowValue =$ CL.consume + liftIO $ print res' + +case_basicView :: Assertion +case_basicView = runCouch conn $ do + _ <- couchView' "test" "group1" [("reduce", Just "false")] $ + (CL.mapM (liftIO . print)) =$ CL.consume + _ <- couchView' "test" "group1" [("reduce", Just "false")] $ + rowValue =$ CL.mapM_ (liftIO . print) + res' <- couchView' "test" "group1" [("reduce", Just "false")] $ + rowValue =$ CL.consume + liftIO $ print res' + +case_basicViewReduce :: Assertion +case_basicViewReduce = runCouch conn $ do + res <- couchView' "test" "group1" [] $ + CL.mapM (liftIO . print) =$ CL.consume + liftIO $ print res + +conn :: CouchConnection +conn = def {couchDB = "cdbc_test"}
+ test/Main.hs view
@@ -0,0 +1,16 @@+ +module Main (main) where + +import Test.Framework (defaultMain) + +import qualified Database.CouchDB.Conduit.Test.Explicit +import qualified Database.CouchDB.Conduit.Test.Generic +import qualified Database.CouchDB.Conduit.Test.View + +main :: IO () +main = defaultMain [ + Database.CouchDB.Conduit.Test.Explicit.tests, + Database.CouchDB.Conduit.Test.Generic.tests, + Database.CouchDB.Conduit.Test.View.tests + ] +