couchdb-conduit 0.8.3 → 0.9.0

raw patch · 6 files changed

+60/−87 lines, 6 filesdep +vectordep ~attoparsec-conduitdep ~conduitdep ~http-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: vector

Dependency ranges changed: attoparsec-conduit, conduit, http-conduit, http-types

API changes (from Hackage documentation)

Files

• couchdb-conduit.cabal +11/−10
• src/Database/CouchDB/Conduit.hs +1/−0
• src/Database/CouchDB/Conduit/Internal/Doc.hs +3/−3
• src/Database/CouchDB/Conduit/LowLevel.hs +3/−3
• src/Database/CouchDB/Conduit/View.hs +36/−65
• test/Database/CouchDB/Conduit/Test/View.hs +6/−6

@@ -1,5 +1,5 @@ name:           couchdb-conduit-version:        0.8.3
+version:        0.9.0
 cabal-version:  >= 1.8 build-type:     Simple stability:      Testing
@@ -28,14 +28,14 @@                    base >= 4 && < 5,                    aeson >= 0.6 && < 0.7,                    attoparsec >= 0.8 && < 0.11,-                   attoparsec-conduit >= 0.4 && < 0.5,+                   attoparsec-conduit >= 0.5 && < 0.6,                    blaze-builder >= 0.2.1 && < 0.4,                    bytestring >= 0.9 && < 0.10,-                   conduit >= 0.4 && < 0.5,+                   conduit >= 0.5 && < 0.6,                    containers >= 0.2,                    data-default,-                   http-conduit >= 1.4 && < 1.5,-                   http-types >= 0.6 && < 0.7,+                   http-conduit >= 1.5 && < 1.6,+                   http-types >= 0.7 && < 0.8,                    lifted-base >= 0.1 && < 0.2,                    monad-control >= 0.3 && < 0.4,                    resourcet,@@ -43,7 +43,8 @@                    syb,                    transformers >= 0.2 && < 0.4,                    text >= 0.11 && < 0.12,-                   unordered-containers >= 0.1+                   unordered-containers >= 0.1,+                   vector   ghc-options:      -Wall   exposed-modules:  
                     Database.CouchDB.Conduit,
@@ -71,14 +72,14 @@                    couchdb-conduit,                    aeson >= 0.6 && < 0.7,                    attoparsec >= 0.8 && < 0.11,-                   attoparsec-conduit >= 0.4 && < 0.5,+                   attoparsec-conduit >= 0.5 && < 0.6,                    blaze-builder >= 0.2.1 && < 0.4,                    bytestring >= 0.9 && < 0.10,-                   conduit >= 0.4 && < 0.5,+                   conduit >= 0.5 && < 0.6,                    containers >= 0.2,                    data-default,-                   http-conduit >= 1.4 && < 1.5,-                   http-types >= 0.6 && < 0.7,+                   http-conduit >= 1.5 && < 1.6,+                   http-types >= 0.7 && < 0.8,                    lifted-base >= 0.1 && < 0.2,                    monad-control >= 0.3 && < 0.4,                    string-conversions,

@@ -18,6 +18,7 @@     -- * Document paths and revisions #path#
     Path,
     Revision,
+    mkPath,
     
     -- * CouchDB Connection #connection#
     CouchConnection,

@@ -22,7 +22,7 @@ import qualified Data.ByteString.Lazy as BL
 import qualified Data.Text.Encoding as TE
 import qualified Data.Aeson as A
-import Data.Conduit (($$))
+import Data.Conduit (($$+-))
 import qualified Data.Conduit.Attoparsec as CA
 
 import qualified Network.HTTP.Conduit as H
@@ -82,7 +82,7 @@     H.Response _ _ _ bsrc <- couch HT.methodGet 
                                  p [] q 
                                  (H.RequestBodyBS B.empty) protect'
-    j <- bsrc $$ CA.sinkParser A.json
+    j <- bsrc $$+- CA.sinkParser A.json
     A.String r <- either throw return $ extractField "_rev" j
     o <- jsonToTypeWith f j 
     return (TE.encodeUtf8 r, o)
@@ -100,7 +100,7 @@     H.Response _ _ _ bsrc <- couch HT.methodPut 
                                  p (ifMatch r) q 
                                  (H.RequestBodyLBS $ f val) protect'
-    j <- bsrc $$ CA.sinkParser A.json
+    j <- bsrc $$+- CA.sinkParser A.json
     either throw return $ extractRev j
   where 
     ifMatch "" = []

@@ -27,7 +27,7 @@ import qualified Data.HashMap.Lazy as M
 import Data.String.Conversions ((<>), cs)
 
-import Data.Conduit (Source, ($$))
+import Data.Conduit (ResumableSource, ($$+-))
 import Data.Conduit.Attoparsec (sinkParser)
                         
 import qualified Network.HTTP.Conduit as H
@@ -36,7 +36,7 @@ import Database.CouchDB.Conduit.Internal.Connection
 
 -- | CouchDB response
-type CouchResponse m = H.Response (Source m B.ByteString)
+type CouchResponse m = H.Response (ResumableSource 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 
@@ -104,7 +104,7 @@     | sc == 304 = throw NotModified
     | sc `elem` goodCodes = h resp
     | otherwise = do
-        v <- catch (bsrc $$ sinkParser A.json)
+        v <- catch (bsrc $$+- sinkParser A.json)
                    (\(_::SomeException) -> return A.Null)
         throw $ CouchHttpError sc $ msg v
         where 

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} 
-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} 
+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, NoMonomorphismRestriction #-} 
 
 -- | Higher-level functions to interact with CouchDB views.
 --   To manipulate views in design documents see 
@@ -10,9 +10,9 @@     -- * Acccessing views #run#
     -- $run
     couchView,
-    couchView',
+    couchView_,
     couchViewPost,
-    couchViewPost',
+    couchViewPost_,
     rowValue,
 
     -- * View query parameters
@@ -53,7 +53,6 @@ )
  where
 
-import Control.Applicative ((<|>))
 import Control.Exception.Lifted (throw)
 
 import Data.Monoid (mconcat)
@@ -65,10 +64,12 @@ import qualified Data.Aeson as A
 import Data.Attoparsec
 
-import Data.Conduit (MonadResource, 
-                        Source, Conduit, Sink, ($$), ($=), 
-                        sequenceSink, SequencedSinkResponse(..),
-                        )
+import qualified Data.Vector.Generic as V
+import qualified Data.Vector.Fusion.Stream as S
+
+import Data.Conduit (MonadResource, Source, Conduit, Sink, ($$), ($=), ($$+-))
+import Data.Conduit.Util (sourceState, SourceStateResult(..))
+                     
 import qualified Data.Conduit.List as CL
 import qualified Data.Conduit.Attoparsec as CA
 
@@ -287,7 +288,7 @@             (viewPath db design view)
             [] q              (H.RequestBodyBS B.empty) protect'
-    return $ bsrc $= conduitCouchView
+    bsrc $$+- conduitRows
 
 -- | Brain-free version of 'couchView'. Takes 'Sink' to consume response.
 --
@@ -299,14 +300,14 @@ -- >     -- ... Or extract row value and consume
 -- >     res <- couchView' "mydb" "mydesign" "myview" [] $ 
 -- >                        rowValue =$ CL.consume
-couchView' :: MonadCouch m =>
+couchView_ :: MonadCouch m =>
        Path                 -- ^ Database     -> Path                 -- ^ Design document
     -> Path                 -- ^ View name
     -> HT.Query             -- ^ Query parameters     -> Sink A.Object m a    -- ^ Sink for handle view rows.     -> m a
-couchView' db design view q sink = do
+couchView_ db design view q sink = do
     raw <- couchView db design view q
     raw $$ sink
 
@@ -332,12 +333,12 @@             [] 
             q 
             (H.RequestBodyLBS mkPost) protect'
-    return $ bsrc $= conduitCouchView
+    bsrc $$+- conduitRows
   where
     mkPost = A.encode $ A.object ["keys" A..= ks]
 
 -- | Brain-free version of 'couchViewPost'. Takes 'Sink' to consume response.
-couchViewPost' :: (MonadCouch m, A.ToJSON a) =>
+couchViewPost_ :: (MonadCouch m, A.ToJSON a) =>
        Path                 -- ^ Database
     -> Path                 -- ^ Design document
     -> Path                 -- ^ View name
@@ -345,7 +346,7 @@     -> a                    -- ^ View @keys@. Must be list or cortege.
     -> Sink A.Object m a    -- ^ Sink for handle view rows.
     -> m a
-couchViewPost' db design view q ks sink = do
+couchViewPost_ db design view q ks sink = do
     raw <- couchViewPost db design view q ks
     raw $$ sink
 
@@ -364,58 +365,28 @@ viewPath :: Path -> Path -> Path -> Path
 viewPath db design view = mkPath [db, "_design", design, "_view", view]
 
------------------------------------------------------------------------------
--- Internal view parser
------------------------------------------------------------------------------
-
-conduitCouchView :: MonadResource m => Conduit B.ByteString m A.Object
-conduitCouchView = sequenceSink () $ \() -> do
-    b <- CA.sinkParser viewStart
-    if b then return $ StartConduit viewLoop
-         else return Stop
-
-viewLoop :: MonadResource 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
-            _ -> throw $ 
-                 CouchInternalError "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
+-- | Use an immutable vector as a source.
+sourceVector :: (Monad m, V.Vector v a) => v a -> Source m a
+sourceVector vec = sourceState (V.stream vec) f
+    where f stream | S.null stream = return StateClosed
+                   | otherwise = return $ StateOpen 
+                        (S.tail stream) (S.head stream)
 
--- determine view
-viewStart :: Parser Bool
-viewStart = do
-    _ <- string "{" 
-    _ <- option "" $ string "\"total_rows\":" 
-    option () $ skipWhile (\x -> x >= 48 && x <= 57)
-    _ <- option "" $ string ",\"update_seq\":" 
-    option () $ skipWhile (\x -> x >= 48 && x <= 57)
-    _ <- option "" $ string ",\"offset\":"
-    option () $ skipWhile (\x -> x >= 48 && x <= 57)
-    _ <- option "" $ string ","
-    _ <- string "\"rows\":["
-    (string "]}" <|> (do
-        r <- string "]"
-        _ <- option "" $ string ",\"update_seq\":"
-        option () $ skipWhile (\x -> x >= 48 && x <= 57)
-        _ <- option "" $ string "}"
-        return r) 
-        >> return False) <|> return True
+-- | Extra
+conduitRows :: MonadResource m => Sink BS8.ByteString m (Source m A.Object)
+--(Monad m1, Control.Monad.Trans.Resource.MonadThrow m) =>+--Data.Conduit.Internal.Pipe BS8.ByteString BS8.ByteString o u m (Source m1 A.Object)
+conduitRows = do 
+    raw <- CA.sinkParser (A.json <?> "json object")
+    rows <- case raw of
+        (A.Object raw') -> case M.lookup "rows" raw' of
+            (Just (A.Array r)) -> return r
+            _ -> return V.empty
+        _ -> throw $ CouchInternalError "view entry is not an object"
+    return $ sourceVector rows $= CL.map valToObj
+  where
+    valToObj (A.Object o) = o
+    valToObj _ = throw $ CouchInternalError "row is not object"
 
     
     

@@ -16,9 +16,9 @@ 
 import qualified Data.ByteString as B
 import Data.String.Conversions ((<>), cs)
+import qualified Data.Aeson as A
 import Data.Aeson ((.:), (.=))
 import qualified Data.HashMap.Strict as H
-import qualified Data.Aeson as A
 --import qualified Data.Aeson.Generic as AG
 import Data.Generics (Data, Typeable)
 import Data.Conduit
@@ -72,10 +72,10 @@         couchPutDB_ db
         couchPutView db "mydesign" "myview"
                 "function(doc){emit(doc.intV, doc);}" Nothing
-        mapM_ (\n -> CCG.couchPut' db (docName n) [] $ doc n) [1..20]
+        mapM_ (\n -> CCG.couchPut' db (docName n) [] $ doc n) [1..200]
     )
     (tearDB db) $ runCouch conn $ do
-        res <- couchView' db "mydesign" "myview" [] $ 
+        res <- couchView_ db "mydesign" "myview" [] $ 
             (rowValue =$= CCG.toType) =$ CL.consume 
         mapM_ (\(a, b) -> liftIO $ a @=? doc b) $ zip res [1..20]
   where 
@@ -93,7 +93,7 @@                 $ Just "function(keys, values){return sum(values);}"
         mapM_ (\n -> CCG.couchPut' db (docName n) [] $ doc n) [1..20])
     (tearDB db) $ runCouch conn $ do
-        res <- couchView' db "mydesign" "myview" [] $
+        res <- couchView_ db "mydesign" "myview" [] $
             (rowValue =$= CCG.toType) =$ CL.consume
         liftIO $ res @=? [ReducedView 210]
   where
@@ -108,7 +108,7 @@                 "function(doc){emit(doc.intV, doc.intV);}" Nothing
         mapM_ (\n -> CCG.couchPut' db (docName n) [] $ doc n) [1..20])
     (tearDB db) $ runCouch conn $ do
-        res <- couchView' db "mydesign" "myview" 
+        res <- couchView_ db "mydesign" "myview" 
             [("update_seq",Just "true"),("key",Just "1")] $
             (rowValue =$= CCG.toType) =$ CL.consume
         liftIO $ res @=? [ReducedView 1]
@@ -124,7 +124,7 @@                 "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
-        res <- couchView' db "mydesign" "myview" 
+        res <- couchView_ db "mydesign" "myview" 
             [("keys",Just "[[0,0]]")] $
             (rowValue =$= CCG.toType) =$ CL.consume
         liftIO $ res @=? ([] :: [ReducedView])