couchdb-conduit 0.7.4 → 0.7.6
raw patch · 8 files changed
+97/−93 lines, 8 filesdep +string-conversionsPVP ok
version bump matches the API change (PVP)
Dependencies added: string-conversions
API changes (from Hackage documentation)
+ Database.CouchDB.Conduit.LowLevel: couch' :: MonadCouch m => Method -> (Path -> Path) -> RequestHeaders -> Query -> RequestBody m -> (CouchResponse m -> ResourceT m (CouchResponse m)) -> ResourceT m (CouchResponse m)
Files
- couchdb-conduit.cabal +2/−1
- src/Database/CouchDB/Conduit.hs +1/−1
- src/Database/CouchDB/Conduit/DB.hs +2/−2
- src/Database/CouchDB/Conduit/Internal/Connection.hs +14/−15
- src/Database/CouchDB/Conduit/Internal/Doc.hs +16/−30
- src/Database/CouchDB/Conduit/Internal/Parser.hs +10/−13
- src/Database/CouchDB/Conduit/Internal/View.hs +7/−7
- src/Database/CouchDB/Conduit/LowLevel.hs +45/−24
couchdb-conduit.cabal view
@@ -1,5 +1,5 @@ name: couchdb-conduit-version: 0.7.4 +version: 0.7.6 cabal-version: >= 1.8 build-type: Simple stability: Stable @@ -41,6 +41,7 @@ utf8-string >= 0.3 && < 0.4, text >= 0.11 && < 0.12, unordered-containers >= 0.1,+ string-conversions, syb, data-default, blaze-builder >= 0.2.1 && < 0.4
src/Database/CouchDB/Conduit.hs view
@@ -60,7 +60,7 @@ couchRev db p = D.couchRev (mkPath [db, p]) -- | Brain-free version of 'couchRev'. If document absent, --- just return 'B.empty'. +-- just return empty ByteString. couchRev' :: MonadCouch m => Path -- ^ Database. -> Path -- ^ Document path.
src/Database/CouchDB/Conduit/DB.hs view
@@ -30,7 +30,7 @@ import Database.CouchDB.Conduit.Internal.Connection (MonadCouch(..), Path, mkPath) -import Database.CouchDB.Conduit.LowLevel (couch, protect, protect') +import Database.CouchDB.Conduit.LowLevel (couch, couch', protect, protect') -- | Create CouchDB database. @@ -91,7 +91,7 @@ -> Bool -- ^ Cancel flag -> ResourceT m () couchReplicateDB source target createTarget continuous cancel = - void $ couch HT.methodPost "_replicate" [] [] + void $ couch' HT.methodPost (const "/_replicate") [] [] reqBody protect' where reqBody = H.RequestBodyLBS $ A.encode $ A.object [
src/Database/CouchDB/Conduit/Internal/Connection.hs view
@@ -29,20 +29,19 @@ ) where -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) -import Control.Exception (Exception) -import Control.Monad.Trans.Class (lift) - -import Data.Conduit (ResourceIO, ResourceT, runResourceT) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Control.Exception (Exception) +import Control.Monad.Trans.Class (lift) -import qualified Network.HTTP.Conduit as H -import qualified Network.HTTP.Types as HT +import Data.Generics (Typeable) +import Data.Default (Default (def)) +import qualified Data.ByteString as B +import qualified Data.Text.Encoding as TE +import qualified Blaze.ByteString.Builder as BLB +import Data.Conduit (ResourceIO, ResourceT, runResourceT) -import Data.Generics (Typeable) -import Data.Default (Default (def)) -import qualified Data.ByteString as B -import qualified Data.Text.Encoding as TE -import qualified Blaze.ByteString.Builder as BLB +import qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT ----------------------------------------------------------------------------- -- Paths @@ -76,7 +75,7 @@ -> Path mkPath = BLB.toByteString . HT.encodePathSegments . map TE.decodeUtf8 . filter (/="") - + ----------------------------------------------------------------------------- -- Connection ----------------------------------------------------------------------------- @@ -98,8 +97,8 @@ , couchPass :: B.ByteString -- ^ CouchDB password. By default is 'B.empty'. , couchPrefix :: B.ByteString - -- ^ CouchDB database prefix. It will prepended to DB pathes. - -- Must be fully valid DB name fragment. + -- ^ CouchDB database prefix. It will prepended to first fragment of + -- request path. Must be fully valid DB name fragment. } instance Default CouchConnection where
src/Database/CouchDB/Conduit/Internal/Doc.hs view
@@ -13,22 +13,25 @@ ) where import Prelude hiding (catch) -import Control.Exception.Lifted (catch) -import Control.Monad.Trans.Class (lift) -import Data.Maybe (fromJust) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text.Encoding as TE -import qualified Data.Aeson as A -import Data.Conduit (ResourceT, resourceThrow, ($$)) -import qualified Data.Conduit.Attoparsec as CA -import qualified Network.HTTP.Conduit as H -import Network.HTTP.Types as HT +import Control.Monad (void) +import Control.Exception.Lifted (catch) +import Control.Monad.Trans.Class (lift) + +import Data.Maybe (fromJust) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Encoding as TE +import qualified Data.Aeson as A +import Data.Conduit (ResourceT, resourceThrow, ($$)) +import qualified Data.Conduit.Attoparsec as CA + +import qualified Network.HTTP.Conduit as H +import Network.HTTP.Types as HT + import Database.CouchDB.Conduit.Internal.Connection import Database.CouchDB.Conduit.LowLevel (couch, protect') import Database.CouchDB.Conduit.Internal.Parser -import Control.Monad (void) ------------------------------------------------------------------------------ -- Type-independent methods @@ -39,8 +42,7 @@ Path -- ^ Correct 'Path' with escaped fragments. -> ResourceT m Revision couchRev p = do - (H.Response _ hs _) <- couch HT.methodHead - p [] [] + (H.Response _ hs _) <- couch HT.methodHead p [] [] (H.RequestBodyBS B.empty) protect' return $ peekRev hs where @@ -129,19 +131,3 @@ couchPutWith' f p q val = do rev <- couchRev' p couchPutWith f p rev q val - - - - - - - - - - - - - - - -
src/Database/CouchDB/Conduit/Internal/Parser.hs view
@@ -2,28 +2,25 @@ module Database.CouchDB.Conduit.Internal.Parser where -import Data.Conduit -import qualified Data.ByteString.UTF8 as BU8 -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 Data.Conduit +import qualified Data.Text as T +import qualified Data.HashMap.Lazy as M +import qualified Data.Aeson as A +import Data.String.Conversions ((<>), cs) -import Database.CouchDB.Conduit.Internal.Connection +import Database.CouchDB.Conduit.Internal.Connection (CouchError(..), Revision) extractField :: T.Text -> A.Value -> Either CouchError A.Value extractField s (A.Object o) = - maybe (Left $ CouchInternalError $ BU8.fromString $ - "unable to find field " ++ (BU8.toString . TE.encodeUtf8 $ s)) - Right - $ M.lookup s o + maybe (Left $ CouchInternalError $ "unable to find field " <> cs s) + Right $ M.lookup s o 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 (Right (A.String a)) = Right $ cs a look _ = Left $ CouchInternalError "CouchDB object has't revision" -- | Convert to type with given convertor @@ -33,6 +30,6 @@ -> m a jsonToTypeWith f j = case f j of A.Error e -> resourceThrow $ CouchInternalError $ - BU8.fromString ("Error parsing json: " ++ e) + "Error parsing json: " <> cs e A.Success o -> return o
src/Database/CouchDB/Conduit/Internal/View.hs view
@@ -1,13 +1,13 @@+{-# LANGUAGE OverloadedStrings #-} module Database.CouchDB.Conduit.Internal.View where -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 qualified Data.Aeson as A +import Data.Conduit (resourceThrow, Conduit(..), ResourceIO) +import qualified Data.Conduit.List as CL (mapM) +import Data.String.Conversions ((<>), cs) -import Database.CouchDB.Conduit.Internal.Connection - (CouchError(..)) +import Database.CouchDB.Conduit.Internal.Connection (CouchError(..)) -- | Convert CouchDB view row or row value from 'Database.CouchDB.Conduit.View' -- to concrete type. @@ -18,5 +18,5 @@ -> Conduit A.Value m a toTypeWith f = CL.mapM (\v -> case f v of A.Error e -> resourceThrow $ CouchInternalError $ - pack ("Error parsing json: " ++ e) + "Error parsing json: " <> cs e A.Success o -> return o)
src/Database/CouchDB/Conduit/LowLevel.hs view
@@ -4,34 +4,39 @@ -- | Low-level method and tools of accessing CouchDB. module Database.CouchDB.Conduit.LowLevel ( + -- * Response CouchResponse, + + -- * Low-level access couch, + couch', + + -- * Response protection protect, protect' ) where import Prelude hiding (catch) -import Control.Exception.Lifted (catch) -import Control.Exception (SomeException) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Base (liftBase) +import Control.Exception.Lifted (catch) +import Control.Exception (SomeException) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Base (liftBase) -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.HashMap.Lazy as M -import qualified Data.Text as T +import Data.Maybe (fromJust) +import qualified Data.ByteString as B +import qualified Data.Aeson as A +import qualified Data.HashMap.Lazy as M +import Data.String.Conversions ((<>), cs) -import Data.Conduit (ResourceT, Source, +import Data.Conduit (ResourceT, Source, ($$), resourceThrow) -import Data.Conduit.Attoparsec (sinkParser) +import Data.Conduit.Attoparsec (sinkParser) -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.Internal.Connection -- | CouchDB response type CouchResponse m = H.Response (Source m B.ByteString) @@ -43,20 +48,40 @@ couch :: MonadCouch m => HT.Method -- ^ Method -> Path -- ^ Correct 'Path' with escaped fragments. + -- 'couchPrefix' will be prepended to path. -> 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 path = + couch' meth withPrefix + where + withPrefix prx + | B.null prx = path + | otherwise = "/" <> prx <> B.tail path + +-- | More generalized version of 'couch'. Instead 'Path' it takes function +-- what takes prefix and returns a path. +couch' :: MonadCouch m => + HT.Method -- ^ Method + -> (Path -> Path) -- ^ 'couchPrefix'->Path function. Output must + -- be correct 'Path' with escaped fragments. + -> 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 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 = withPrefix $ couchPrefix conn + , H.path = pathFn $ couchPrefix conn , H.queryString = HT.renderQuery False qs , H.requestBody = reqBody , H.checkStatus = const . const $ Nothing } @@ -65,10 +90,6 @@ (couchLogin conn) (couchPass conn) req res <- H.http req' (fromJust $ couchManager conn) protectFn res - where - withPrefix prx - | B.null prx = path - | otherwise = "/" `B.append` prx `B.append` B.tail path -- | Protect 'H.Response' from bad status codes. If status code in list -- of status codes - just return response. Otherwise - throw 'CouchError'. @@ -90,9 +111,9 @@ (\(_::SomeException) -> return A.Null) liftBase $ resourceThrow $ CouchHttpError sc $ msg v where - 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 + msg v = sm <> reason v + reason (A.Object v) = case M.lookup "reason" v of + Just (A.String t) -> ": " <> cs t _ -> "" reason _ = B.empty