couchdb-conduit 0.5.3 → 0.6.0

raw patch · 5 files changed

+148/−112 lines, 5 filesdep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: unordered-containers

API changes (from Hackage documentation)

Files

• couchdb-conduit.cabal +3/−3
• src/Database/CouchDB/Conduit.hs +1/−8
• src/Database/CouchDB/Conduit/Design.hs +21/−45
• src/Database/CouchDB/Conduit/View.hs +110/−36
• test/Database/CouchDB/Conduit/Test/View.hs +13/−20

@@ -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

@@ -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` "\""

@@ -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 

@@ -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 
+-- <http://wiki.apache.org/couchdb/HTTP_view_API#Querying_Options>. 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

@@ -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"