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.1.3.0 +version: 0.2.0 cabal-version: >= 1.8 build-type: Simple stability: Experimental @@ -17,7 +17,6 @@ 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 source-repository head type: git diff --git a/src/Database/CouchDB/Conduit/DB.hs b/src/Database/CouchDB/Conduit/DB.hs --- a/src/Database/CouchDB/Conduit/DB.hs +++ b/src/Database/CouchDB/Conduit/DB.hs @@ -1,58 +1,79 @@ -{- | CouchDB database methods. +{-# LANGUAGE OverloadedStrings #-} -/Note about paths./ If you passed a database name to -"Database.CouchDB.Conduit#connection", the path in methods below should be the -'B.empty'. But, if you passed the 'B.empty' to 'CouchConnection', then the -@couchDB@ should be used in these methods. +{- | CouchDB database methods. > runCouch def $ couchPutDb "my_new_db" -> runCouch def {couchDB="another_new_db"} $ couchPutDb "" +> runCouch def {couchDB="my_new_db"} $ couchPutDb "another_new_db" + +/Note./ All database methods ignores database settings in connection. -} module Database.CouchDB.Conduit.DB ( -- * Methods couchPutDB, - couchPutDB', - couchDeleteDB + couchPutDB_, + couchDeleteDB, + couchReplicateDB ) where -import Prelude hiding (catch) -import Control.Exception.Lifted (catch) - import qualified Data.ByteString as B +import qualified Data.Aeson as A -import Data.Conduit (ResourceT, resourceThrow) +import Data.Conduit (ResourceT) import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT -import Database.CouchDB.Conduit (MonadCouch(..), CouchError(..), Path) -import Database.CouchDB.Conduit.LowLevel (couch, protect') -import Control.Monad.Trans.Class (lift) +import Database.CouchDB.Conduit (MonadCouch(..), Path) +import Database.CouchDB.Conduit.LowLevel (couch, protect, protect') --- | Create CouchDB database. +-- | Create CouchDB database. couchPutDB :: MonadCouch m => - Path -- ^ CouchDB Database name. See note above. + Path -- ^ CouchDB Database name. -> ResourceT m () -couchPutDB p = couch HT.methodPut p [] [] - (H.RequestBodyBS B.empty) protect' +couchPutDB p = couch HT.methodPut (const p) [] [] + (H.RequestBodyBS B.empty) protect' >> return () --- | Brute force version of couchPutDb. Create CouchDB database regardless --- of presence. Catches 'CouchError' @412@. -couchPutDB' :: MonadCouch m => - Path -- ^ CouchDB Database name. See note above. +-- | \"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 = - catch (couchPutDB p) handler - where - handler (CouchError (Just 412) _) = return () - handler e = lift $ resourceThrow e +couchPutDB_ p = + couch HT.methodPut (const p) [] [] + (H.RequestBodyBS B.empty) + (protect [200, 201, 202, 304, 412] return) + >> return () -- | Delete a database. couchDeleteDB :: MonadCouch m => - Path -- ^ CouchDB Database name. See note above. + Path -- ^ CouchDB Database name. -> ResourceT m () -couchDeleteDB p = couch HT.methodDelete p [] [] - (H.RequestBodyBS B.empty) protect' +couchDeleteDB p = couch HT.methodDelete (const p) [] [] + (H.RequestBodyBS B.empty) protect' >> return () + +-- | Database replication. +-- +-- See for +-- details. +couchReplicateDB :: MonadCouch m => + B.ByteString -- ^ Source database. Path or URL + -> B.ByteString -- ^ Target database. Path or URL + -> Bool -- ^ Target creation flag + -> Bool -- ^ Continuous flag + -> Bool -- ^ Cancel flag + -> ResourceT m () +couchReplicateDB source target createTarget continuous cancel = + couch HT.methodPost (const "_replicate") [] [] + reqBody protect' + >> return () + where + reqBody = H.RequestBodyLBS $ A.encode $ A.object [ + "source" A..= source, + "target" A..= target, + "create_target" A..= createTarget, + "continuous" A..= continuous, + "cancel" A..= cancel + ] 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,7 +4,7 @@ -- convenient for bootstrapping and testing. module Database.CouchDB.Conduit.Design ( - couchViewPut, + couchViewPut_, couchViewPut' ) where @@ -25,23 +25,23 @@ -- | Put view in design document if it not exists. If design document does -- not exist, it will be created. -couchViewPut' :: MonadCouch m => +couchViewPut_ :: MonadCouch m => Path -- ^ Design document -> Path -- ^ View name -> B.ByteString -- ^ Map function -> Maybe B.ByteString -- ^ Reduce function -> ResourceT m Revision -couchViewPut' = couchViewPutInt True +couchViewPut_ = 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 => +couchViewPut' :: MonadCouch m => Path -- ^ Design document -> Path -- ^ View name -> B.ByteString -- ^ Map function -> Maybe B.ByteString -- ^ Reduce function -> ResourceT m Revision -couchViewPut = couchViewPutInt False +couchViewPut' = couchViewPutInt False ----------------------------------------------------------------------------- -- Internal diff --git a/src/Database/CouchDB/Conduit/Explicit.hs b/src/Database/CouchDB/Conduit/Explicit.hs --- a/src/Database/CouchDB/Conduit/Explicit.hs +++ b/src/Database/CouchDB/Conduit/Explicit.hs @@ -44,8 +44,10 @@ -- * Accessing documents couchGet, couchRev, + couchRev', -- * Manipulating documents couchPut, + couchPut_, couchPut', couchDelete, -- * Working with views #view# @@ -58,8 +60,7 @@ import Network.HTTP.Types as HT import Database.CouchDB.Conduit (MonadCouch(..), Path, Revision) -import Database.CouchDB.Conduit.Internal.Doc (couchRev, - couchDelete, couchGetWith, couchPutWith, couchPutWith') +import Database.CouchDB.Conduit.Internal.Doc import Database.CouchDB.Conduit.Internal.View (toTypeWith) ------------------------------------------------------------------------------ @@ -83,7 +84,17 @@ -> ResourceT m Revision couchPut = couchPutWith A.encode --- | Brute force version of 'couchPut'. +-- | \"Don't care\" version of 'couchPut'. Creates document only in its +-- absence. +couchPut_ :: (MonadCouch m, A.ToJSON a) => + Path -- ^ Document path. + -> HT.Query -- ^ Query arguments. + -> a -- ^ The object to store. + -> ResourceT m Revision +couchPut_ = couchPutWith_ A.encode + +-- | Brute force version of 'couchPut'. Creates a document regardless of +-- presence. couchPut' :: (MonadCouch m, A.ToJSON a) => Path -- ^ Document path. -> HT.Query -- ^ Query arguments. diff --git a/src/Database/CouchDB/Conduit/Generic.hs b/src/Database/CouchDB/Conduit/Generic.hs --- a/src/Database/CouchDB/Conduit/Generic.hs +++ b/src/Database/CouchDB/Conduit/Generic.hs @@ -41,8 +41,10 @@ -- * Accessing documents couchGet, couchRev, + couchRev', -- * Manipulating documents couchPut, + couchPut_, couchPut', couchDelete, -- * Working with views #view# @@ -76,7 +78,17 @@ -> ResourceT m Revision couchPut = couchPutWith AG.encode --- | Brute force version of 'couchPut'. +-- | \"Don't care\" version of 'couchPut'. Creates document only in its +-- absence. +couchPut_ :: (MonadCouch m, Data a) => + Path -- ^ Document path. + -> HT.Query -- ^ Query arguments. + -> a -- ^ The object to store. + -> ResourceT m Revision +couchPut_ = couchPutWith_ AG.encode + +-- | Brute force version of 'couchPut'. Creates a document regardless of +-- presence. couchPut' :: (MonadCouch m, Data a) => Path -- ^ Document path. -> HT.Query -- ^ Query arguments. diff --git a/src/Database/CouchDB/Conduit/Internal/Doc.hs b/src/Database/CouchDB/Conduit/Internal/Doc.hs --- a/src/Database/CouchDB/Conduit/Internal/Doc.hs +++ b/src/Database/CouchDB/Conduit/Internal/Doc.hs @@ -3,13 +3,13 @@ -- | Internal module Database.CouchDB.Conduit.Internal.Doc ( couchRev, + couchRev', couchDelete, couchGetWith, couchPutWith, - couchPutWith', - - couchGetRaw + couchPutWith_, + couchPutWith' ) where import Prelude hiding (catch) @@ -26,8 +26,7 @@ import Network.HTTP.Types as HT import Database.CouchDB.Conduit -import Database.CouchDB.Conduit.LowLevel - (couch, protect') +import Database.CouchDB.Conduit.LowLevel (couch') import Database.CouchDB.Conduit.Internal.Parser ------------------------------------------------------------------------------ @@ -36,39 +35,48 @@ -- | Get Revision of a document. couchRev :: MonadCouch m => - Path + Path -- ^ Path -> ResourceT m Revision couchRev p = do - (H.Response _ hs _) <- couch HT.methodHead p [] [] - (H.RequestBodyBS B.empty) - protect' + (H.Response _ hs _) <- couch' HT.methodHead p [] [] + (H.RequestBodyBS B.empty) return $ peekRev hs where peekRev = B.tail . B.init . fromJust . lookup "Etag" +-- | Brain-free version of 'couchRev'. If document absent, +-- just return 'B.empty'. +couchRev' :: MonadCouch m => + Path + -> ResourceT m Revision +couchRev' p = + catch (couchRev p) handler404 + where + handler404 (CouchError (Just 404) _) = return B.empty + handler404 e = lift $ resourceThrow e + -- | Delete the given revision of the object. couchDelete :: MonadCouch m => Path -> Revision -> ResourceT m () -couchDelete p r = couch HT.methodDelete p - [] [("rev", Just r)] - (H.RequestBodyBS B.empty) - protect' >> return () +couchDelete p r = couch' HT.methodDelete p [] [("rev", Just r)] + (H.RequestBodyBS B.empty) + >> return () ------------------------------------------------------------------------------ -- with converter ------------------------------------------------------------------------------ --- | Load CouchDB document and parse it with given parser +-- | Load CouchDB document and parse it with given parser. couchGetWith :: MonadCouch m => (A.Value -> A.Result a) -- ^ Parser -> Path -- ^ Path -> Query -- ^ Query -> ResourceT m (Revision, a) couchGetWith f p q = do - H.Response _ _ bsrc <- couch HT.methodGet p [] q - (H.RequestBodyBS B.empty) protect' + H.Response _ _ bsrc <- couch' HT.methodGet p [] q + (H.RequestBodyBS B.empty) j <- bsrc $$ CA.sinkParser A.json A.String r <- lift $ either resourceThrow return $ extractField "_rev" j o <- lift $ jsonToTypeWith f j @@ -84,14 +92,28 @@ -> a -- ^ The object to store. -> ResourceT m Revision couchPutWith f p r q val = do - H.Response _ _ bsrc <- couch HT.methodPut p (ifMatch r) q - (H.RequestBodyLBS $ f val) protect' + H.Response _ _ bsrc <- couch' HT.methodPut p (ifMatch r) q + (H.RequestBodyLBS $ f val) j <- bsrc $$ CA.sinkParser A.json lift $ either resourceThrow return $ extractRev j where ifMatch "" = [] ifMatch rv = [("If-Match", rv)] +-- | \"Don't care\" version of version of 'couchPutWith'. Stores +-- document only if it not exists. +couchPutWith_ :: MonadCouch m => + (a -> BL.ByteString) -- ^ Encoder + -> Path -- ^ Document path. + -> HT.Query -- ^ Query arguments. + -> a -- ^ The object to store. + -> ResourceT m Revision +couchPutWith_ f p q val = do + rev <- couchRev' p + if rev == "" + then couchPutWith f p "" q val + else return rev + -- | Brute force version of 'couchPutWith'. couchPutWith' :: MonadCouch m => (a -> BL.ByteString) -- ^ Encoder @@ -100,21 +122,21 @@ -> a -- ^ The object to store. -> ResourceT m Revision couchPutWith' f p q val = do - rev <- catch (couchRev p) handler404 + rev <- couchRev' p couchPutWith f p rev q val - where - 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) + + + + + + + + + + + + + + diff --git a/src/Database/CouchDB/Conduit/Internal/Parser.hs b/src/Database/CouchDB/Conduit/Internal/Parser.hs --- a/src/Database/CouchDB/Conduit/Internal/Parser.hs +++ b/src/Database/CouchDB/Conduit/Internal/Parser.hs @@ -11,12 +11,6 @@ import Database.CouchDB.Conduit ---valToRev :: A.Value -> Either CouchError Revision ---valToRev (A.Object o) = case M.lookup "rev" o of --- (Just (A.String r)) -> Right $ TE.encodeUtf8 r --- _ -> Left $ CouchError Nothing "unable to find revision" ---valToRev _ = Left $ CouchError Nothing "Couch DB did not return an object" - extractField :: T.Text -> A.Value -> Either CouchError A.Value extractField s (A.Object o) = maybe (Left $ CouchError Nothing $ @@ -40,3 +34,4 @@ A.Error e -> resourceThrow $ CouchError Nothing ("Error parsing json: " ++ e) A.Success o -> return o + diff --git a/src/Database/CouchDB/Conduit/LowLevel.hs b/src/Database/CouchDB/Conduit/LowLevel.hs --- a/src/Database/CouchDB/Conduit/LowLevel.hs +++ b/src/Database/CouchDB/Conduit/LowLevel.hs @@ -6,6 +6,7 @@ module Database.CouchDB.Conduit.LowLevel ( CouchResponse, couch, + couch', protect, protect' ) where @@ -42,33 +43,47 @@ -- attachments that are not in JSON format. couch :: MonadCouch m => HT.Method -- ^ Method - -> Path -- ^ Path + -> (Path -> Path) -- ^ Path creation function -> HT.RequestHeaders -- ^ Headers -> HT.Query -- ^ Query args -> H.RequestBody m -- ^ Request body -> (CouchResponse m -> ResourceT m (CouchResponse m)) -- ^ Protect function. See 'protect' -> ResourceT m (CouchResponse m) -couch meth path hdrs qs reqBody protectFn = do +couch meth pathFn hdrs qs reqBody protectFn = do conn <- lift couchConnection let req = H.def { H.method = meth , H.host = couchHost conn , H.requestHeaders = hdrs , H.port = couchPort conn - , H.path = B.intercalate "/" . filter (/="") $ - [couchDB conn, path] + , H.path = pathFn $ couchDB conn , H.queryString = HT.renderQuery False qs , H.requestBody = reqBody , H.checkStatus = const . const $ Nothing } -- Apply auth if needed let req' = if couchLogin conn == B.empty then req else H.applyBasicAuth (couchLogin conn) (couchPass conn) req - -- FIXME fromJust res <- H.http req' (fromJust $ couchManager conn) protectFn res - +-- | Simplified version of 'couch'. This version uses standart path +-- creation and protect functions. +couch' :: MonadCouch m => + HT.Method -- ^ Method + -> Path -- ^ Path + -> HT.RequestHeaders -- ^ Headers + -> HT.Query -- ^ Query args + -> H.RequestBody m -- ^ Request body + -> ResourceT m (CouchResponse m) +couch' meth p hdrs qs reqBody = + couch meth + (\dbP -> mkPath [dbP, p]) + hdrs + qs + reqBody + protect' + -- | Protect 'H.Response' from bad status codes. If status code in list -- of status codes - just return response. Otherwise - throw 'CouchError'. -- @@ -77,11 +92,12 @@ -- -- To protect from typical errors use 'protect''. protect :: MonadCouch m => - [Int] -- ^ Good codes + [Int] -- ^ Good codes + -> (CouchResponse m -> ResourceT m (CouchResponse m)) -- ^ handler -> CouchResponse m -- ^ Response -> ResourceT m (CouchResponse m) -protect goodCodes ~resp@(H.Response (HT.Status sc sm) _ bsrc) - | sc `elem` goodCodes = return resp +protect goodCodes h ~resp@(H.Response (HT.Status sc sm) _ bsrc) + | sc `elem` goodCodes = h resp | otherwise = do v <- catch (bsrc $$ sinkParser A.json) (\(_::SomeException) -> return A.Null) @@ -93,9 +109,12 @@ _ -> "" reason _ = [] --- | Protect from typical status codes: 200, 201, 202 and 304. See 'protect' --- fo details. +-- | Protect from typical status codes. It's equivalent of +-- +-- > protect [200, 201, 202, 304] return +-- +-- See 'protect' for details. protect' :: MonadCouch m => CouchResponse m -- ^ Response -> ResourceT m (CouchResponse m) -protect' = protect [200, 201, 202, 304] +protect' = protect [200, 201, 202, 304] return 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 @@ -31,7 +31,7 @@ import qualified Network.HTTP.Types as HT import Database.CouchDB.Conduit -import Database.CouchDB.Conduit.LowLevel (couch, protect') +import Database.CouchDB.Conduit.LowLevel (couch') ----------------------------------------------------------------------------- -- Running @@ -67,13 +67,13 @@ -> HT.Query -- ^ Query parameters -> ResourceT m (Source m A.Object) couchView designDocName viewName q = do - H.Response _ _ bsrc <- couch HT.methodGet fullPath [] q - (H.RequestBodyBS B.empty) protect' + H.Response _ _ bsrc <- couch' HT.methodGet fullPath [] q + (H.RequestBodyBS B.empty) return $ bsrc $= conduitCouchView where fullPath = B.concat ["_design/", designDocName, "/_view/", viewName] --- | Brain-free version of 'runCouch'. Takes 'Sink' to consume response. +-- | Brain-free version of 'couchView'. Takes 'Sink' to consume response. -- -- > runCouch def {couchDB="mydb"} $ do -- > @@ -89,8 +89,8 @@ -> Sink A.Object m a -- ^ Sink for handle view rows. -> ResourceT m a couchView' designDocName viewName q sink = do - H.Response _ _ bsrc <- couch HT.methodGet fullPath [] q - (H.RequestBodyBS B.empty) protect' + H.Response _ _ bsrc <- couch' HT.methodGet fullPath [] q + (H.RequestBodyBS B.empty) bsrc $= conduitCouchView $$ sink where fullPath = mkPath ["_design", designDocName, "_view", viewName] diff --git a/test/Database/CouchDB/Conduit/Test/Explicit.hs b/test/Database/CouchDB/Conduit/Test/Explicit.hs --- a/test/Database/CouchDB/Conduit/Test/Explicit.hs +++ b/test/Database/CouchDB/Conduit/Test/Explicit.hs @@ -54,8 +54,7 @@ couchPut (docn n) "" [] $ TestDoc "doc" n $ show n ) [1..100] liftIO $ length revs @=? 100 - revs' <- mapM (\n -> - couchRev $ docn n) [1..100] + revs' <- mapM (\n -> couchRev $ docn n) [1..100] liftIO $ revs @=? revs' liftIO $ length revs' @=? 100 mapM_ (\(n,r) -> diff --git a/test/Database/CouchDB/Conduit/Test/Generic.hs b/test/Database/CouchDB/Conduit/Test/Generic.hs --- a/test/Database/CouchDB/Conduit/Test/Generic.hs +++ b/test/Database/CouchDB/Conduit/Test/Generic.hs @@ -22,7 +22,7 @@ tests :: Test tests = mutuallyExclusive $ testGroup "Generic" [ testCase "Just put-get-delete" case_justPutGet, - testCase "Mass flow" case_massFlow, +-- testCase "Mass flow" case_massFlow, testCase "Mass Iter" case_massIter ] @@ -47,8 +47,7 @@ couchPut (docn n) "" [] $ TestDoc "doc" n $ show n ) [1..100] liftIO $ length revs @=? 100 - revs' <- mapM (\n -> - couchRev $ docn n) [1..100] + revs' <- mapM (\n -> couchRev $ docn n) [1..100] liftIO $ revs @=? revs' liftIO $ length revs' @=? 100 mapM_ (\(n,r) -> diff --git a/test/Database/CouchDB/Conduit/Test/Util.hs b/test/Database/CouchDB/Conduit/Test/Util.hs --- a/test/Database/CouchDB/Conduit/Test/Util.hs +++ b/test/Database/CouchDB/Conduit/Test/Util.hs @@ -8,7 +8,7 @@ import Database.CouchDB.Conduit.DB setupDB :: ByteString -> IO () -setupDB n = runCouch def {couchDB = n} $ couchPutDB "" +setupDB n = runCouch def $ couchPutDB_ n tearDB :: ByteString -> IO () -tearDB n = runCouch def {couchDB = n} $ couchDeleteDB "" +tearDB n = runCouch def $ couchDeleteDB n 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 @@ -53,7 +53,7 @@ case_createView = bracket_ (setupDB db) (tearDB db) $ runCouch (conn db) $ do - rev <- couchViewPut "mydesign" "myview" + rev <- couchViewPut' "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 "" - _ <- couchViewPut "mydesign" "myview" + couchPutDB db + _ <- couchViewPut' "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 "" - _ <- couchViewPut "mydesign" "myview" + couchPutDB db + _ <- 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])