couchdb-conduit 0.1.0.1 → 0.1.1.0

raw patch · 7 files changed

+196/−145 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• couchdb-conduit.cabal +21/−20
• src/Database/CouchDB/Conduit/Design.hs +63/−0
• src/Database/CouchDB/Conduit/Internal/Doc.hs +19/−19
• src/Database/CouchDB/Conduit/Internal/Parser.hs +12/−13
• src/Database/CouchDB/Conduit/LowLevel.hs +5/−5
• src/Database/CouchDB/Conduit/View.hs +6/−50
• test/Database/CouchDB/Conduit/Test/View.hs +70/−38

@@ -1,12 +1,12 @@ name:           couchdb-conduit-version:        0.1.0.1
+version:        0.1.1.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>+author:         Alexander Dorofeev <aka.spin@gmail.com>, John Lenz <lenz@math.uic.edu>
 maintainer:     Alexander Dorofeev <aka.spin@gmail.com> synopsis:       Couch DB client library using http-conduit and aeson homepage:       https://github.com/akaspin/couchdb-conduit@@ -17,7 +17,7 @@     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
+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@@ -46,17 +46,18 @@                    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+  exposed-modules:  
+                    Database.CouchDB.Conduit,
+                    Database.CouchDB.Conduit.DB,
+                    Database.CouchDB.Conduit.Design,
+                    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@@ -86,12 +87,12 @@                    syb,                    containers,                    blaze-builder-  ghc-options:     -Wall -rtsopts -threaded
+  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+  other-modules:   
+                   Database.CouchDB.Conduit.Test.Explicit,
+                   Database.CouchDB.Conduit.Test.Util,
+                   Database.CouchDB.Conduit.Test.View,
+                   Database.CouchDB.Conduit.Test.Generic
 

@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} 
+
+-- | High-level API for CouchDB design documents. These methods are very 
+--   convenient for bootstrapping and testing.
+
+module Database.CouchDB.Conduit.Design (
+    couchViewPut
+) where
+
+import              Prelude hiding (catch)
+import              Control.Exception.Lifted (catch)
+
+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 Database.CouchDB.Conduit (MonadCouch, CouchError, Path, mkPath, Revision)
+import Database.CouchDB.Conduit.Internal.Doc (couchGetWith, couchPutWith)
+
+-- | Put view in design document. If design document does not exist, it 
+--   will be created. 
+couchViewPut :: MonadCouch m =>
+       Path                 -- ^ Design document
+    -> Path                 -- ^ View name
+    -> B.ByteString         -- ^ Map function
+    -> Maybe B.ByteString   -- ^ Reduce function
+    -> ResourceT m Revision
+couchViewPut designName viewName mapF reduceF = do
+    -- Get design or empty object
+    (rev, A.Object d) <- catch 
+        (couchGetWith (A.Success) path [])
+        (\(_ :: CouchError) -> return (B.empty, AT.emptyObject))
+    couchPutWith A.encode path rev [] $ inferViews (purge_ d)
+  where
+    path = (mkPath ["_design", designName])
+    inferViews d = A.Object $ M.insert "views" (addView d) d
+    addView d = A.Object $ M.insert 
+        (TE.decodeUtf8 viewName)
+        (constructView mapF reduceF) 
+        (extractViews d)
+    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]
+
+-- | Purge underscore fields
+purge_ :: AT.Object -> AT.Object
+purge_ = M.filterWithKey (\k _ -> not $ k `elem` ["_id", "_rev"])
+
+-- | Strip 'A.Value'
+stripObject :: AT.Value -> AT.Object
+stripObject (A.Object a) = a 
+stripObject _ = M.empty 
+
+-- Extract views field or return empty map
+extractViews :: M.HashMap T.Text AT.Value -> M.HashMap T.Text AT.Value
+extractViews o = maybe M.empty stripObject $ M.lookup "views" o
+
+

@@ -4,11 +4,12 @@ module Database.CouchDB.Conduit.Internal.Doc (
     couchRev,
     couchDelete,
-    couchGetRaw,
     
     couchGetWith,
     couchPutWith,
-    couchPutWith'
+    couchPutWith',
+    
+    couchGetRaw
 ) where
 
 import              Prelude hiding (catch)
@@ -25,7 +26,8 @@ import              Network.HTTP.Types as HT
 
 import              Database.CouchDB.Conduit
-import              Database.CouchDB.Conduit.LowLevel (couch, protect')
+import              Database.CouchDB.Conduit.LowLevel 
+                        (couch, protect')
 import              Database.CouchDB.Conduit.Internal.Parser
 
 ------------------------------------------------------------------------------
@@ -55,20 +57,6 @@                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
 ------------------------------------------------------------------------------
 
@@ -82,7 +70,7 @@     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
+    A.String r <- lift $ either resourceThrow return $ extractField "_rev" j
     o <- lift $ jsonToTypeWith f j 
     return (TE.encodeUtf8 r, o)
 
@@ -99,7 +87,7 @@     H.Response _ _ bsrc <- couch HT.methodPut p (ifMatch r) q 
             (H.RequestBodyLBS $ f val) protect'
     j <- bsrc $$ CA.sinkParser A.json
-    lift $ extractRev j
+    lift $ either resourceThrow return $ extractRev j
   where 
     ifMatch "" = []
     ifMatch rv = [("If-Match", rv)]
@@ -118,3 +106,15 @@     handler404 (CouchError (Just 404) _) = return ""
     handler404 e = lift $ resourceThrow e
 
+
+-- | Load raw 'A.Value' from single object from couch DB.
+couchGetRaw :: MonadCouch m => 
+       Path         -- ^ Document path
+    -> HT.Query     -- ^ Query
+    -> ResourceT m (Revision, A.Value)
+couchGetRaw 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 $ either resourceThrow return $ extractField "_rev" j
+    return (TE.encodeUtf8 r, j)

@@ -17,20 +17,19 @@ --    _  -> 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
+extractField :: T.Text -> A.Value -> Either CouchError A.Value
+extractField s (A.Object o) = 
+    maybe (Left $ CouchError Nothing $ 
+            "unable to find field " ++ (BU8.toString . TE.encodeUtf8 $ s))
+          Right 
+          $ M.lookup s o
+extractField _ _ = Left $ CouchError Nothing "Couch DB did not return an object"
 
--- | 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"
+extractRev :: A.Value -> Either CouchError Revision
+extractRev = look . extractField "rev"
+  where 
+    look (Right (A.String a)) = Right $ TE.encodeUtf8 a
+    look _ = Left $ CouchError Nothing "CouchDB object has't revision"
 
 -- | Convert to type with given convertor
 jsonToTypeWith :: ResourceIO m =>

@@ -19,7 +19,7 @@ 
 import              Data.Maybe (fromJust)
 import qualified    Data.ByteString as B
-import              Data.Aeson (json, Value(..))
+import qualified    Data.Aeson as A
 import qualified    Data.ByteString.UTF8 as BU8
 import qualified    Data.HashMap.Lazy as M
 import qualified    Data.Text as T
@@ -79,13 +79,13 @@ 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)
+        v <- catch (bsrc $$ sinkParser A.json)
+                   (\(_::SomeException) -> return A.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 (A.Object v) = case M.lookup "reason" v of
+                Just (A.String t) -> ": " ++ T.unpack t
                 _                 -> ""
         reason _ = []
 

@@ -2,6 +2,8 @@ {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} 
 
 -- | Higher-level functions to interact with CouchDB views.
+--   To manipulate views in design documents see 
+--   "Database.CouchDB.Conduit.Design"
 
 module Database.CouchDB.Conduit.View 
 (
@@ -9,21 +11,13 @@     -- $run
     couchView,
     couchView',
-    rowValue,
-    -- * Manipulating views
-    couchViewPut
+    rowValue
 )
  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
@@ -38,7 +32,6 @@ 
 import              Database.CouchDB.Conduit
 import              Database.CouchDB.Conduit.LowLevel (couch, protect')
-import qualified    Database.CouchDB.Conduit.Generic as CCG
 
 -----------------------------------------------------------------------------
 -- Running
@@ -100,7 +93,7 @@         (H.RequestBodyBS B.empty) protect'
     bsrc $= conduitCouchView $$ sink
   where
-    fullPath = B.concat ["_design/", designDocName, "/_view/", viewName]
+    fullPath = mkPath ["_design", designDocName, "_view", viewName]
 
 -- | Conduit for extract \"value\" field from CouchDB view row.
 rowValue :: ResourceIO m => Conduit A.Object m A.Value
@@ -110,44 +103,6 @@                         "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
 -----------------------------------------------------------------------------
 
@@ -190,4 +145,5 @@     option () $ skipWhile (\x -> x >= 48 && x <= 57)
     _ <- option "" $ string ","
     _ <- string "\"rows\":["
-    (string "]}" >> return False) <|> return True+    (string "]}" >> return False) <|> return True
+    

@@ -6,24 +6,34 @@ 
 import Test.Framework (testGroup, mutuallyExclusive, Test)
 import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit (Assertion)
+import Test.HUnit (Assertion, (@=?))
+import Database.CouchDB.Conduit.Test.Util (setupDB, tearDB)
 
 --import Control.Monad.Trans.Class (lift)
+import Control.Exception.Lifted (bracket_)
 import Control.Monad.IO.Class (liftIO)
+import Control.Applicative ((<$>), (<*>), empty)
 
-import              Data.Generics (Data, Typeable)
+import qualified Data.ByteString as B
+import Data.ByteString.UTF8 (fromString)
+import Data.Aeson ((.:), (.=))
+import qualified Data.Aeson as A
+--import qualified Data.Aeson.Generic as AG
+import Data.Generics (Data, Typeable)
 import Data.Conduit
 import qualified Data.Conduit.List as CL
 
 import Database.CouchDB.Conduit
+import qualified Database.CouchDB.Conduit.Generic as CCG
+import Database.CouchDB.Conduit.DB
 import Database.CouchDB.Conduit.View
-import Control.Monad.Trans.Reader (runReaderT)+import Database.CouchDB.Conduit.Design
 
 tests :: Test
 tests = mutuallyExclusive $ testGroup "View" [
-    testCase "Basic" case_basicViewM
---    testCase "Basic" case_basicView,
---    testCase "Basic with reduce" case_basicViewReduce
+    testCase "Create" case_createView,
+    testCase "Big values parsing" case_bigValues,
+    testCase "View with reduce" case_withReduce
     ]
 
 data T = T {
@@ -32,39 +42,61 @@     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'')
+instance A.FromJSON T where
+   parseJSON (A.Object v) = T <$> v .: "kind" <*> v .: "intV" <*> v .: "strV"
+   parseJSON _          = empty
+   
+instance A.ToJSON T where
+   toJSON (T k i s) = A.object ["kind" .= k, "intV" .= i, "strV" .= s]
 
-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_createView :: Assertion
+case_createView = bracket_
+    (setupDB db)
+    (tearDB db) $ runCouch (conn db) $ do
+        rev <- couchViewPut "mydesign" "myview"
+            "function(doc){emit(null, doc);}" Nothing
+        rev' <- CCG.couchRev "_design/mydesign"
+        liftIO $ rev @=? rev' 
+  where 
+    db = "cdbc_test_view_create"
 
-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_bigValues :: Assertion
+case_bigValues = bracket_
+    (runCouch (conn db) $ do
+        couchPutDB ""
+        _ <- couchViewPut "mydesign" "myview"
+                "function(doc){emit(doc.intV, doc);}" Nothing
+        mapM_ (\n -> CCG.couchPut' (docName n) [] $ doc n) [1..20]
+    )
+    (tearDB db) $ runCouch (conn db) $ do
+        res <- couchView' "mydesign" "myview" [] $ 
+            (rowValue =$= CCG.toType) =$ CL.consume 
+        mapM_ (\(a, b) -> liftIO $ a @=? doc b) $ zip res [1..20]
+  where 
+    db = "cdbc_test_view_big_values"
+    doc n = T "doc" n $ concat $ replicate 10000 (show n)
 
-case_basicViewReduce :: Assertion
-case_basicViewReduce = runCouch conn $ do
-    res <- couchView' "test" "group1" [] $ 
-        CL.mapM (liftIO . print) =$ CL.consume
-    liftIO $ print res
+data ReducedView = ReducedView Int deriving (Show, Eq, Data, Typeable)
+
+case_withReduce :: Assertion    
+case_withReduce = bracket_
+    (runCouch (conn db) $ do
+        couchPutDB ""
+        _ <- couchViewPut "mydesign" "myview"
+                "function(doc){emit(doc.intV, doc.intV);}" 
+                $ Just "function(keys, values){return sum(values);}"
+        mapM_ (\n -> CCG.couchPut' (docName n) [] $ doc n) [1..20])
+    (tearDB db) $ runCouch (conn db) $ do
+        res <- couchView' "mydesign" "myview" [] $
+            (rowValue =$= CCG.toType) =$ CL.consume
+        liftIO $ res @=? [ReducedView 210]
+  where
+    db = "cdbc_test_view_reduce"
+    doc n = T "doc" n $ show n
     
-conn :: CouchConnection
-conn = def {couchDB = "cdbc_test"} 
+docName :: Int -> B.ByteString
+docName n = fromString $ "doc" ++ show n    
+
+-- | connection
+conn :: Path -> CouchConnection
+conn db = def {couchDB = db}