couchdb-conduit 0.3.0.1 → 0.4.0

raw patch · 12 files changed

+59/−61 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• couchdb-conduit.cabal +1/−1
• src/Database/CouchDB/Conduit.hs +12/−5
• src/Database/CouchDB/Conduit/DB.hs +8/−21
• src/Database/CouchDB/Conduit/Design.hs +6/−6
• src/Database/CouchDB/Conduit/Internal/Doc.hs +1/−1
• src/Database/CouchDB/Conduit/Internal/Parser.hs +4/−4
• src/Database/CouchDB/Conduit/Internal/View.hs +3/−3
• src/Database/CouchDB/Conduit/LowLevel.hs +7/−6
• src/Database/CouchDB/Conduit/View.hs +5/−4
• test/Database/CouchDB/Conduit/Test/Base.hs +5/−3
• test/Database/CouchDB/Conduit/Test/Util.hs +2/−2
• test/Database/CouchDB/Conduit/Test/View.hs +5/−5

@@ -1,5 +1,5 @@ name:           couchdb-conduit-version:        0.3.0.1
+version:        0.4.0
 cabal-version:  >= 1.8 build-type:     Simple stability:      Experimental

@@ -148,11 +148,18 @@ 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)
+-- | A CouchDB Error.
+data CouchError 
+    = CouchHttpError Int B.ByteString
+        -- ^ Error comes from http.
+    | CouchInternalError B.ByteString
+        -- ^ Non-http errors include things like errors  
+        --   parsing the response.
+    | NotModified
+        -- ^ /Is not an error actually/. It is thrown when CouchDB returns 
+        --   @304 - Not Modified@ response to the request. See 
+        --   <http://wiki.apache.org/couchdb/HTTP_Document_API>
+  deriving (Show, Typeable)
 instance Exception CouchError
 
 -- | Run a sequence of CouchDB actions. This function is a combination of 

@@ -3,10 +3,8 @@ 
 {- | CouchDB database methods.
 
-> runCouch def $ couchPutDb "my_new_db"
-> runCouch def {couchDB="my_new_db"} $ couchPutDb "another_new_db"
-
-/Note./ All database methods ignores database settings in connection.
+> runCouch def {couchDB="my_db"} $ couchPutDb
+> runCouch def {couchDB="my_new_db"} $ couchPutDb
 -}
 
 module Database.CouchDB.Conduit.DB (
@@ -20,12 +18,8 @@     couchSecureDB
 ) where
 
---import Control.Applicative ((<$>), (<*>), empty)
-
 import qualified Data.ByteString as B
 import qualified Data.Aeson as A
---import Data.Generics (Data, Typeable)
---import Data.Default (Default (def))
 
 import Data.Conduit (ResourceT)
 
@@ -37,29 +31,22 @@ 
 
 -- | Create CouchDB database. 
-couchPutDB :: MonadCouch m =>
-       Path     -- ^ CouchDB Database name.
-    -> ResourceT m ()
-couchPutDB p = couch HT.methodPut (const p) [] []
+couchPutDB :: MonadCouch m => ResourceT m ()
+couchPutDB = couch HT.methodPut id [] []
                     (H.RequestBodyBS B.empty) protect' 
                     >> return ()
 
 -- | \"Don't care\" version of couchPutDb. Create CouchDB database only in its 
 --   absence. For this it handles @412@ responses.
-couchPutDB_ :: MonadCouch m =>
-       Path     -- ^ CouchDB Database name.
-    -> ResourceT m ()
-couchPutDB_ p = 
-    couch HT.methodPut (const p) [] []
+couchPutDB_ :: MonadCouch m => ResourceT m ()
+couchPutDB_ = couch HT.methodPut id [] []
                     (H.RequestBodyBS B.empty) 
                     (protect [200, 201, 202, 304, 412] return) 
                     >> return ()
 
 -- | Delete a database.
-couchDeleteDB :: MonadCouch m => 
-       Path     -- ^ CouchDB Database name.
-    -> ResourceT m ()
-couchDeleteDB p = couch HT.methodDelete (const p) [] []
+couchDeleteDB :: MonadCouch m => ResourceT m ()
+couchDeleteDB = couch HT.methodDelete id [] []
                     (H.RequestBodyBS B.empty) protect' 
                     >> return ()
 

@@ -4,8 +4,8 @@ --   convenient for bootstrapping and testing.
 
 module Database.CouchDB.Conduit.Design (
-    couchViewPut_,
-    couchViewPut'
+    couchPutView_,
+    couchPutView'
 ) where
 
 import              Prelude hiding (catch)
@@ -26,23 +26,23 @@ 
 -- | Put view in design document if it not exists. If design document does 
 --   not exist, it will be created. 
-couchViewPut_ :: MonadCouch m =>
+couchPutView_ :: MonadCouch m =>
        Path                 -- ^ Design document
     -> Path                 -- ^ View name
     -> B.ByteString         -- ^ Map function
     -> Maybe B.ByteString   -- ^ Reduce function
     -> ResourceT m Revision
-couchViewPut_ = couchViewPutInt True
+couchPutView_ = couchViewPutInt True
 
 -- | Brute-force version of 'couchViewPut''. Put view in design document. 
 --   If design document does not exist, it will be created. 
-couchViewPut' :: MonadCouch m =>
+couchPutView' :: MonadCouch m =>
        Path                 -- ^ Design document
     -> Path                 -- ^ View name
     -> B.ByteString         -- ^ Map function
     -> Maybe B.ByteString   -- ^ Reduce function
     -> ResourceT m Revision
-couchViewPut' = couchViewPutInt False
+couchPutView' = couchViewPutInt False
 
 -----------------------------------------------------------------------------
 -- Internal

@@ -52,7 +52,7 @@ couchRev' p = 
     catch (couchRev p) handler404
   where
-    handler404 (CouchError (Just 404) _) = return B.empty
+    handler404 (CouchHttpError 404 _) = return B.empty
     handler404 e = lift $ resourceThrow e
 
 -- | Delete the given revision of the object.    

@@ -13,17 +13,17 @@ 
 extractField :: T.Text -> A.Value -> Either CouchError A.Value
 extractField s (A.Object o) = 
-    maybe (Left $ CouchError Nothing $ 
+    maybe (Left $ CouchInternalError $ BU8.fromString $
             "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"
+extractField _ _ = Left $ CouchInternalError "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"
+    look _ = Left $ CouchInternalError "CouchDB object has't revision"
 
 -- | Convert to type with given convertor
 jsonToTypeWith :: ResourceIO m =>@@ -31,7 +31,7 @@              -> A.Value 
              -> m a
 jsonToTypeWith f j = case f j of
-        A.Error e -> resourceThrow $ CouchError Nothing 
+        A.Error e -> resourceThrow $ CouchInternalError $ BU8.fromString $
                         ("Error parsing json: " ++ e)
         A.Success o -> return o
 

@@ -4,7 +4,7 @@ import qualified    Data.Aeson as A
 import              Data.Conduit (resourceThrow, Conduit(..), ResourceIO)
 import qualified    Data.Conduit.List as CL (mapM)
-
+import Data.ByteString.Char8 (pack)
 
 import              Database.CouchDB.Conduit
 
@@ -16,6 +16,6 @@     (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.Error e -> resourceThrow $ CouchInternalError $
+                           pack ("Error parsing json: " ++ e)
             A.Success o -> return o)

@@ -20,8 +20,8 @@ 
 import              Data.Maybe (fromJust)
 import qualified    Data.ByteString as B
+import qualified    Data.ByteString.Char8 as BC8
 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
 
@@ -96,18 +96,19 @@     -> (CouchResponse m -> ResourceT m (CouchResponse m)) -- ^ handler
     -> CouchResponse m   -- ^ Response
     -> ResourceT m (CouchResponse m)
-protect goodCodes h ~resp@(H.Response (HT.Status sc sm) _ bsrc)  
+protect goodCodes h ~resp@(H.Response (HT.Status sc sm) _ bsrc)
+    | sc == 304 = liftBase $ resourceThrow NotModified
     | sc `elem` goodCodes = h resp
     | otherwise = do
         v <- catch (bsrc $$ sinkParser A.json)
                    (\(_::SomeException) -> return A.Null)
-        liftBase $ resourceThrow $ CouchError (Just sc) $ msg v
+        liftBase $ resourceThrow $ CouchHttpError sc $ msg v
         where 
-        msg v = BU8.toString sm ++ reason v
-        reason (A.Object v) = case M.lookup "reason" v of
+        msg v = sm `B.append` reason v
+        reason (A.Object v) = BC8.pack $ case M.lookup "reason" v of
                 Just (A.String t) -> ": " ++ T.unpack t
                 _                 -> ""
-        reason _ = []
+        reason _ = B.empty
 
 -- | Protect from typical status codes. It's equivalent of
 --

@@ -19,6 +19,7 @@ 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
@@ -98,9 +99,9 @@ -- | 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)
+            (Just o) -> return o
+            _ -> resourceThrow $ CouchInternalError $ BC8.pack
+                    ("View row does not contain value: " ++ show v))
 
 -----------------------------------------------------------------------------
 -- Internal Parser conduit
@@ -120,7 +121,7 @@         vobj <- case v of
             (A.Object o) -> return o
             _ -> lift $ resourceThrow $ 
-                 CouchError Nothing "view entry is not an object"
+                 CouchInternalError "view entry is not an object"
         res <- CA.sinkParser (commaOrClose <?> "comma or close")
         case res of
             Comma -> return $ Emit False [vobj]

@@ -37,8 +37,10 @@ 
 -- | Put and delete
 case_dbPut :: Assertion    
-case_dbPut =  runCouch def {couchLogin = login, couchPass=pass} $ do
-    couchPutDB_ "cdbc_dbputdel"
-    couchDeleteDB "cdbc_dbputdel"
+case_dbPut =  runCouch def {couchLogin = login, 
+                            couchPass=pass,
+                            couchDB="cdbc_dbputdel"} $ do
+    couchPutDB_
+    couchDeleteDB
     
     

@@ -10,10 +10,10 @@ import CouchDBAuth
 
 setupDB :: ByteString -> IO ()
-setupDB n = runCouch (conn n) $ couchPutDB_ n
+setupDB n = runCouch (conn n) $ couchPutDB_
 
 tearDB :: ByteString -> IO ()
-tearDB n = runCouch (conn n) $ couchDeleteDB n
+tearDB n = runCouch (conn n) $ couchDeleteDB
 
 -- | Connection connection. See readme
 conn :: Path -> CouchConnection

@@ -53,7 +53,7 @@ case_createView = bracket_
     (setupDB db)
     (tearDB db) $ runCouch (conn db) $ do
-        rev <- couchViewPut' "mydesign" "myview"
+        rev <- couchPutView' "mydesign" "myview"
             "function(doc){emit(null, doc);}" Nothing
         rev' <- CCG.couchRev "_design/mydesign"
         liftIO $ rev @=? rev' 
@@ -63,8 +63,8 @@ case_bigValues :: Assertion
 case_bigValues = bracket_
     (runCouch (conn db) $ do
-        couchPutDB_ db
-        _ <- couchViewPut' "mydesign" "myview"
+        couchPutDB_
+        _ <- couchPutView' "mydesign" "myview"
                 "function(doc){emit(doc.intV, doc);}" Nothing
         mapM_ (\n -> CCG.couchPut' (docName n) [] $ doc n) [1..20]
     )
@@ -81,8 +81,8 @@ case_withReduce :: Assertion    
 case_withReduce = bracket_
     (runCouch (conn db) $ do
-        couchPutDB_ db
-        _ <- couchViewPut' "mydesign" "myview"
+        couchPutDB_
+        _ <- couchPutView' "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])