diff --git a/couchdb-conduit.cabal b/couchdb-conduit.cabal --- a/couchdb-conduit.cabal +++ b/couchdb-conduit.cabal @@ -1,5 +1,5 @@ name: couchdb-conduit -version: 0.5.3 +version: 0.6.0 cabal-version: >= 1.8 build-type: Simple stability: Stable @@ -40,7 +40,7 @@ lifted-base >= 0.1 && < 0.2, utf8-string >= 0.3 && < 0.4, text >= 0.11 && < 0.12, - unordered-containers >= 0.1 && < 0.2, + unordered-containers >= 0.1, syb, data-default, blaze-builder >= 0.2.1 && < 0.4 @@ -83,7 +83,7 @@ lifted-base >= 0.1 && < 0.2, utf8-string >= 0.3 && < 0.4, text >= 0.11 && < 0.12, - unordered-containers >= 0.1 && < 0.2, + unordered-containers >= 0.1, syb, data-default, blaze-builder >= 0.2.1 && < 0.4 diff --git a/src/Database/CouchDB/Conduit.hs b/src/Database/CouchDB/Conduit.hs --- a/src/Database/CouchDB/Conduit.hs +++ b/src/Database/CouchDB/Conduit.hs @@ -43,13 +43,10 @@ -- * "Database.CouchDB.Conduit.Generic" Generic JSON methods couchRev, couchRev', - couchDelete, + couchDelete - -- * Utility - quoteQueryParam ) where -import Data.ByteString (ByteString, append) import Data.Conduit (ResourceT) import Database.CouchDB.Conduit.Internal.Connection import qualified Database.CouchDB.Conduit.Internal.Doc as D @@ -76,7 +73,3 @@ -> Revision -- ^ Revision -> ResourceT m () couchDelete db p = D.couchDelete (mkPath [db, p]) - --- | Simple query param quotation. -quoteQueryParam :: ByteString -> ByteString -quoteQueryParam a = "\"" `append` a `append` "\"" diff --git a/src/Database/CouchDB/Conduit/Design.hs b/src/Database/CouchDB/Conduit/Design.hs --- a/src/Database/CouchDB/Conduit/Design.hs +++ b/src/Database/CouchDB/Conduit/Design.hs @@ -4,66 +4,38 @@ -- convenient for bootstrapping and testing. module Database.CouchDB.Conduit.Design ( - couchPutView_, - couchPutView' + couchPutView ) where import Prelude hiding (catch) -import Control.Exception.Lifted (catch) +import Control.Monad (void) +import Control.Exception.Lifted (catch) -import Data.Conduit (ResourceT) +import Data.Conduit (ResourceT) -import qualified Data.ByteString as B -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 qualified Data.Aeson.Types as AT +import qualified Data.ByteString as B +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 qualified Data.Aeson.Types as AT import Database.CouchDB.Conduit.Internal.Connection (MonadCouch, CouchError, Path, mkPath, Revision) -import Database.CouchDB.Conduit.Internal.Doc (couchGetWith, - couchPutWith_, couchPutWith') - --- | Put view in design document if it not exists. If design document does --- not exist, it will be created. -couchPutView_ :: MonadCouch m => - Path -- ^ Database - -> Path -- ^ Design document - -> Path -- ^ View name - -> B.ByteString -- ^ Map function - -> Maybe B.ByteString -- ^ Reduce function - -> ResourceT m Revision -couchPutView_ = couchViewPutInt True +import Database.CouchDB.Conduit.Internal.Doc (couchGetWith, couchPutWith') --- | Brute-force version of 'couchViewPut''. Put view in design document. --- If design document does not exist, it will be created. -couchPutView' :: MonadCouch m => +-- | Put view to design document. If design document does not exist, +-- it will be created. +couchPutView :: MonadCouch m => Path -- ^ Database -> Path -- ^ Design document -> Path -- ^ View name -> B.ByteString -- ^ Map function -> Maybe B.ByteString -- ^ Reduce function - -> ResourceT m Revision -couchPutView' = couchViewPutInt False - ------------------------------------------------------------------------------ --- Internal ------------------------------------------------------------------------------ - -couchViewPutInt :: MonadCouch m => - Bool -- ^ Care flag - -> Path -- ^ Database - -> Path -- ^ Design document - -> Path -- ^ View name - -> B.ByteString -- ^ Map function - -> Maybe B.ByteString -- ^ Reduce function - -> ResourceT m Revision -couchViewPutInt prot db designName viewName mapF reduceF = do - -- Get design or empty object + -> ResourceT m () +couchPutView db designName viewName mapF reduceF = do (_, A.Object d) <- getDesignDoc path - if prot then couchPutWith_ A.encode path [] $ inferViews (purge_ d) - else couchPutWith' A.encode path [] $ inferViews (purge_ d) + void $ couchPutWith' A.encode path [] $ inferViews (purge_ d) where path = designDocPath db designName inferViews d = A.Object $ M.insert "views" (addView d) d @@ -74,6 +46,10 @@ constructView :: B.ByteString -> Maybe B.ByteString -> A.Value constructView m (Just r) = A.object ["map" A..= m, "reduce" A..= r] constructView m Nothing = A.object ["map" A..= m] + +----------------------------------------------------------------------------- +-- Internal +----------------------------------------------------------------------------- getDesignDoc :: MonadCouch m => Path diff --git a/src/Database/CouchDB/Conduit/View.hs b/src/Database/CouchDB/Conduit/View.hs --- a/src/Database/CouchDB/Conduit/View.hs +++ b/src/Database/CouchDB/Conduit/View.hs @@ -6,38 +6,68 @@ -- "Database.CouchDB.Conduit.Design" module Database.CouchDB.Conduit.View -( +( -- * Acccessing views #run# -- $run couchView, couchView', - rowValue + couchViewPost, + couchViewPost', + rowValue, + + -- * View query parameters + -- $view_query #view_query# + mkParam ) where -import Control.Monad.Trans.Class (lift) -import Control.Applicative ((<|>)) +import Control.Monad.Trans.Class (lift) +import Control.Applicative ((<|>)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC8 -import qualified Data.HashMap.Lazy as M -import qualified Data.Aeson as A -import Data.Attoparsec +import Data.Monoid (mconcat) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.HashMap.Lazy as M +import qualified Data.Aeson as A +import Data.Attoparsec -import Data.Conduit (ResourceIO, ResourceT, +import Data.Conduit (ResourceIO, ResourceT, Source, Conduit, Sink, ($$), ($=), sequenceSink, SequencedSinkResponse(..), resourceThrow ) -import qualified Data.Conduit.List as CL -import qualified Data.Conduit.Attoparsec as CA +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 qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT -import Database.CouchDB.Conduit.Internal.Connection -import Database.CouchDB.Conduit.LowLevel (couch, protect') +import Database.CouchDB.Conduit.Internal.Connection +import Database.CouchDB.Conduit.LowLevel (couch, protect') ----------------------------------------------------------------------------- +-- View query parameters +----------------------------------------------------------------------------- + +-- $view_query +-- For details see +-- . Note, +-- because all options must be a proper URL encoded JSON, construction of +-- complex parameters can be very tedious. To simplify this, use 'mkParam'. + +-- | Encode query parameter to 'B.ByteString'. +-- +-- > mkParam (["a", "b"] :: [String]) +-- > "[\"a\",\"b\"]" +-- +-- It't just convert lazy 'BL.ByteString' from 'A.encode' to strict +-- 'B.ByteString' +mkParam :: A.ToJSON a => + a -- ^ Parameter + -> B.ByteString +mkParam = mconcat . BL.toChunks . A.encode + +----------------------------------------------------------------------------- -- Running ----------------------------------------------------------------------------- @@ -69,39 +99,75 @@ Path -- ^ Database -> Path -- ^ Design document -> Path -- ^ View name - -> HT.Query -- ^ Query parameters + -> HT.Query -- ^ Query parameters -> ResourceT m (Source m A.Object) -couchView db designDocName viewName q = do - H.Response _ _ bsrc <- couch HT.methodGet fullPath [] q - (H.RequestBodyBS B.empty) protect' +couchView db design view q = do + H.Response _ _ bsrc <- couch HT.methodGet + (viewPath db design view) + [] q + (H.RequestBodyBS B.empty) protect' return $ bsrc $= conduitCouchView - where - fullPath = mkPath [db, "_design", designDocName, "_view", viewName] -- | Brain-free version of 'couchView'. Takes 'Sink' to consume response. --- --- > runCouch def $ do +-- +-- > runCouch def $ do -- > --- > -- Print all upon receipt. --- > couchView' "mydb" "mydesign" "myview" [] $ CL.mapM_ (liftIO . print) +-- > -- Print all upon receipt. +-- > couchView' "mydb" "mydesign" "myview" [] $ CL.mapM_ (liftIO . print) -- > -- > -- ... Or extract row value and consume -- > res <- couchView' "mydb" "mydesign" "myview" [] $ -- > rowValue =$ CL.consume -couchView' :: MonadCouch m => - Path -- ^ Database +couchView' :: MonadCouch m => + Path -- ^ Database -> Path -- ^ Design document - -> Path -- ^ View name + -> Path -- ^ View name -> HT.Query -- ^ Query parameters - -> Sink A.Object m a -- ^ Sink for handle view rows. + -> Sink A.Object m a -- ^ Sink for handle view rows. -> ResourceT m a -couchView' db designDocName viewName q sink = do - H.Response _ _ bsrc <- couch HT.methodGet fullPath [] q - (H.RequestBodyBS B.empty) protect' - bsrc $= conduitCouchView $$ sink +couchView' db design view q sink = do + raw <- couchView db design view q + raw $$ sink + +-- | Run CouchDB view in manner like 'H.http' using @POST@ (since CouchDB 0.9). +-- It's convenient in case that @keys@ paremeter too big for @GET@ query +-- string. Other query parameters used as usual. +-- +-- > runCouch def $ do +-- > src <- couchViewPost "mydb" "mydesign" "myview" +-- > [("group", Just "true")] +-- > ["key1", "key2", "key3"] +-- > src $$ CL.mapM_ (liftIO . print) +couchViewPost :: (MonadCouch m, A.ToJSON a) => + Path -- ^ Database + -> Path -- ^ Design document + -> Path -- ^ View name + -> HT.Query -- ^ Query parameters + -> a -- ^ View @keys@. Must be list or cortege. + -> ResourceT m (Source m A.Object) +couchViewPost db design view q ks = do + H.Response _ _ bsrc <- couch HT.methodPost + (viewPath db design view) + [] + q + (H.RequestBodyLBS mkPost) protect' + return $ bsrc $= conduitCouchView where - fullPath = mkPath [db, "_design", designDocName, "_view", viewName] + mkPost = A.encode $ A.object ["keys" A..= ks] +-- | Brain-free version of 'couchViewPost'. Takes 'Sink' to consume response. +couchViewPost' :: (MonadCouch m, A.ToJSON a) => + Path -- ^ Database + -> Path -- ^ Design document + -> Path -- ^ View name + -> HT.Query -- ^ Query parameters + -> a -- ^ View @keys@. Must be list or cortege. + -> Sink A.Object m a -- ^ Sink for handle view rows. + -> ResourceT m a +couchViewPost' db design view q ks sink = do + raw <- couchViewPost db design view q ks + raw $$ sink + -- | 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 @@ -110,7 +176,15 @@ ("View row does not contain value: " ++ show v)) ----------------------------------------------------------------------------- --- Internal Parser conduit +-- Internal +----------------------------------------------------------------------------- + +-- | Make full view path +viewPath :: Path -> Path -> Path -> Path +viewPath db design view = mkPath [db, "_design", design, "_view", view] + +----------------------------------------------------------------------------- +-- Internal view parser ----------------------------------------------------------------------------- conduitCouchView :: ResourceIO m => Conduit B.ByteString m A.Object diff --git a/test/Database/CouchDB/Conduit/Test/View.hs b/test/Database/CouchDB/Conduit/Test/View.hs --- a/test/Database/CouchDB/Conduit/Test/View.hs +++ b/test/Database/CouchDB/Conduit/Test/View.hs @@ -7,7 +7,7 @@ import Test.Framework (testGroup, mutuallyExclusive, Test) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, (@=?)) -import Database.CouchDB.Conduit.Test.Util (setupDB, tearDB, conn) +import Database.CouchDB.Conduit.Test.Util (tearDB, conn) --import Control.Monad.Trans.Class (lift) import Control.Exception.Lifted (bracket_) @@ -31,7 +31,7 @@ tests :: Test tests = mutuallyExclusive $ testGroup "View" [ - testCase "Create" caseCreateView, + testCase "Params" caseMakeParams, testCase "Big values parsing" caseBigValues, testCase "With reduce" caseWithReduce, testCase "update_seq before rows" caseUpdateSeqTop, @@ -51,22 +51,18 @@ instance A.ToJSON T where toJSON (T k i s) = A.object ["kind" .= k, "intV" .= i, "strV" .= s] -caseCreateView :: Assertion -caseCreateView = bracket_ - (setupDB db) - (tearDB db) $ runCouch conn $ do - rev <- couchPutView' db "mydesign" "myview" - "function(doc){emit(null, doc);}" Nothing - rev' <- couchRev db "_design/mydesign" - liftIO $ rev @=? rev' - where - db = "cdbc_test_view_create" +caseMakeParams :: Assertion +caseMakeParams = do + let numP = mkParam (1 :: Int) + let bsP = mkParam ("a" :: B.ByteString) + let arrP = mkParam (["a", "b", "c"] :: [B.ByteString]) + liftIO $ ("1","\"a\"","[\"a\",\"b\",\"c\"]") @=? (numP, bsP, arrP) caseBigValues :: Assertion caseBigValues = bracket_ (runCouch conn $ do couchPutDB_ db - _ <- couchPutView' db "mydesign" "myview" + couchPutView db "mydesign" "myview" "function(doc){emit(doc.intV, doc);}" Nothing mapM_ (\n -> CCG.couchPut' db (docName n) [] $ doc n) [1..20] ) @@ -84,7 +80,7 @@ caseWithReduce = bracket_ (runCouch conn $ do couchPutDB_ db - _ <- couchPutView' db "mydesign" "myview" + couchPutView db "mydesign" "myview" "function(doc){emit(doc.intV, doc.intV);}" $ Just "function(keys, values){return sum(values);}" mapM_ (\n -> CCG.couchPut' db (docName n) [] $ doc n) [1..20]) @@ -100,7 +96,7 @@ caseUpdateSeqTop = bracket_ (runCouch conn $ do couchPutDB_ db - _ <- couchPutView' db "mydesign" "myview" + couchPutView db "mydesign" "myview" "function(doc){emit(doc.intV, doc.intV);}" Nothing mapM_ (\n -> CCG.couchPut' db (docName n) [] $ doc n) [1..20]) (tearDB db) $ runCouch conn $ do @@ -116,7 +112,7 @@ caseUpdateSeqAfter = bracket_ (runCouch conn $ do couchPutDB_ db - _ <- couchPutView' db "mydesign" "myview" + couchPutView db "mydesign" "myview" "function(doc){emit([doc.intV,doc.intV], doc.intV);}" Nothing mapM_ (\n -> CCG.couchPut' db (docName n) [] $ doc n) [1..20]) (tearDB db) $ runCouch conn $ do @@ -124,10 +120,7 @@ [("keys",Just "[[0,0]]")] $ (rowValue =$= CCG.toType) =$ CL.consume liftIO $ res @=? ([] :: [ReducedView]) - res' <- couchView' db "mydesign" "myview" - [] $ - (rowValue) =$ CL.consume - liftIO $ print (res') + where db = "cdbc_test_view_after"