couchdb-enumerator 0.2.1 → 0.3.0
raw patch · 3 files changed
+92/−51 lines, 3 filesdep ~containers
Dependency ranges changed: containers
Files
- Database/CouchDB/Enumerator.hs +83/−45
- couchdb-enumerator.cabal +3/−3
- tests.hs +6/−3
Database/CouchDB/Enumerator.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, OverloadedStrings, FlexibleInstances #-} -- | This module is a very thin wrapper around "Network.HTTP.Enumerator" using the aeson package to parse -- and encode JSON. The Couch DB HTTP API is the best place to learn about how to use this library.@@ -6,6 +6,7 @@ -- -- > {-# LANGUAGE OverloadedStrings #-} -- > import Control.Monad.IO.Class (liftIO)+-- > import Contorl.Monad.Reader -- > import Data.Aeson -- > import qualified Data.ByteString.Lazy as BL -- > import Data.ByteString.UTF8 (fromString)@@ -14,7 +15,7 @@ -- > import Database.CouchDB.Enumerator -- > -- > testCouch :: IO ()--- > testCouch = withCouchConnection "localhost" 5984 "test" $ runCouchT $ do+-- > testCouch = withCouchConnection "localhost" 5984 "test" $ runReaderT $ do -- > -- > -- Insert some documents. Note that the dbname passed to withCouchConnection -- > -- is prepended to the given path, so this is a put to@@ -59,7 +60,7 @@ CouchConnection(..) , withCouchConnection , CouchError(..)- , CouchMonad(..)+ , MonadCouch(..) -- * Accessing Couch DB , Path@@ -72,9 +73,8 @@ , extractViewValue , couch - -- * A ReaderT CouchMonad- , CouchT(..)- , runCouchT+ -- * Connection Pooling+ -- $pool ) where import Control.Applicative@@ -82,7 +82,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Control (MonadControlIO, liftIOOp) import Control.Monad.Trans.Class (MonadTrans, lift)-import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Trans.Reader (ReaderT, ask) import qualified Data.Aeson as A import Data.Attoparsec import Data.Attoparsec.Enumerator (iterParser)@@ -96,7 +96,12 @@ import qualified Network.HTTP.Enumerator as H import qualified Network.HTTP.Types as HT --- | Represents a (pooled) connection to a single Couch DB Dabase.+-- | Represents a connection to a single Couch DB Database. +--+-- A connection contains a 'H.Manager' and reuses it for multiple requests, which means a +-- single open HTTP connection to CouchDB will be kept around until the manager is closed+-- (http-enumerator will create more connections if needed, it just keeps only one and+-- closes the rest.) See the Pool section for more information. data CouchConnection = CouchConnection { host :: B.ByteString , port :: Int@@ -119,10 +124,13 @@ deriving (Show,Typeable) instance Exception CouchError --- | A monad which allows access to the couch connection.-class (MonadIO m) => CouchMonad m where+-- | A monad which allows access to the connection.+class MonadIO m => MonadCouch m where couchConnection :: m CouchConnection +instance (MonadIO m) => MonadCouch (ReaderT CouchConnection m) where+ couchConnection = ask+ -- | A path to a Couch DB Object. type Path = String @@ -132,18 +140,19 @@ -- | 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 functions, but this function is needed for example to write -- and read attachments that are not in JSON format.-couch :: (CouchMonad m) => HT.Method -- ^ Method- -> Path -- ^ The dbname from the connection is prepended to- -- this path.- -> HT.Query -- ^ Query arguments- -> Iteratee B.ByteString m a -- ^ Iteratee to process the response if no error occurs.- -> H.RequestBody m -- ^ Body- -> Iteratee B.ByteString m a+couch :: MonadCouch m+ => HT.Method -- ^ Method+ -> Path -- ^ The dbname from the connection is prepended to+ -- this path.+ -> HT.Query -- ^ Query arguments+ -> Iteratee B.ByteString m a -- ^ Iteratee to process the response if no error occurs.+ -> H.RequestBody m -- ^ Body+ -> Iteratee B.ByteString m a couch m p q i b = Iteratee $ do conn <- couchConnection let req = H.Request { H.method = m , H.secure = False- , H.checkCerts = const $ return False+ , H.checkCerts = const $ error "no cert checking" , H.host = host conn , H.port = port conn , H.path = BU8.fromString ("/" ++ dbname conn ++ "/" ++ p)@@ -156,14 +165,15 @@ runIteratee $ H.http req (\s _ -> checkStatus s i) (manager conn) -- | Load a single object from couch DB.-couchGet :: (CouchMonad m) => Path -- ^ the dbname is prepended to this string to form the full path.- -> HT.Query -- ^ Query arguments.- -> m A.Object+couchGet :: MonadCouch m+ => Path -- ^ the dbname is prepended to this string to form the full path.+ -> HT.Query -- ^ Query arguments.+ -> m A.Object couchGet p q = do v <- run_ $ couch HT.methodGet p q (iterParser A.json) (H.RequestBodyBS B.empty) either throw return $ valToObj v -- | Put an object in Couch DB, returning the new Revision.-couchPut :: (CouchMonad m, A.ToJSON a) +couchPut :: (MonadCouch m, A.ToJSON a) => Path -- ^ the dbname is prepended to this string to form the full path. -> HT.Query -- ^ Query arguments. -> a -- ^ The object to store.@@ -174,7 +184,7 @@ -- | A version of 'couchPut' which ignores the return value. This is slightly faster than / _ <- couchPut .../ -- since the JSON parser is not run.-couchPut_ :: (CouchMonad m, A.ToJSON a) +couchPut_ :: (MonadCouch m, A.ToJSON a) => Path -- ^ the dbname is prepended to this string to form the full path. -> HT.Query -- ^ Query arguments. -> a -- ^ The object to store.@@ -183,9 +193,10 @@ where body = H.RequestBodyLBS $ A.encode $ A.toJSON val -- | Delete the given revision of the object.-couchDelete :: (CouchMonad m) => Path -- ^ the dbname is prepended to this string to form the full path. - -> Revision- -> m ()+couchDelete :: MonadCouch m+ => Path -- ^ the dbname is prepended to this string to form the full path. + -> Revision+ -> m () couchDelete p r = run_ $ couch HT.methodDelete p [("rev", Just $ TE.encodeUtf8 r)] (yield () EOF) (H.RequestBodyBS B.empty) @@ -202,9 +213,10 @@ -- with the 'extractViewValue' enumeratee, for example: -- -- > couchView "mydesigndoc/_view/myview" [(fromString "key", Just $ fromString "3")] $= extractViewValue-couchView :: (CouchMonad m) => Path -- ^ \/dbname\/_design\/ is prepended to the given path- -> HT.Query -- ^ Query arguments.- -> Enumerator A.Object m a+couchView :: MonadCouch m+ => Path -- ^ \/dbname\/_design\/ is prepended to the given path+ -> HT.Query -- ^ Query arguments.+ -> Enumerator A.Object m a couchView p q step = do s <- lift $ run $ couch HT.methodGet ("_design/" ++ p) q (parseView step) (H.RequestBodyBS B.empty) either throwError returnI s @@ -217,30 +229,19 @@ -- > { "id":"64ACF01B05F53ACFEC48C062A5D01D89", "key":null, "value": { some object } } -- -- and this enumeratee will extract /{some object}/-extractViewValue :: (Monad m) => Enumeratee A.Object A.Object m a+extractViewValue :: Monad m => Enumeratee A.Object A.Object m a extractViewValue = mapEither f where f v = case M.lookup "value" v of (Just (A.Object o)) -> Right o _ -> Left $ CouchError Nothing "view does not contain value" --- | ReaderT implementation of CouchMonad.-newtype CouchT m a = CouchT (ReaderT CouchConnection m a)- deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadControlIO)--instance (MonadIO m) => CouchMonad (CouchT m) where- couchConnection = CouchT ask---- | Run a Couch DB backend.-runCouchT :: (Monad m) => CouchT m a -> CouchConnection -> m a-runCouchT (CouchT r) = runReaderT r- ----------------------------------------------------------------------------------------- --- Helper Code ----------------------------------------------------------------------------------------- -- | Check status codes from couch db.-checkStatus :: (Monad m) => HT.Status -> Iteratee B.ByteString m b - -> Iteratee B.ByteString m b+checkStatus :: Monad m => HT.Status -> Iteratee B.ByteString m b + -> Iteratee B.ByteString m b checkStatus (HT.Status 200 _) i = i checkStatus (HT.Status 201 _) i = i checkStatus (HT.Status 202 _) i = i@@ -273,7 +274,7 @@ -- | The main loop of processing the view rows.-viewLoop :: (MonadIO m) => Enumeratee B.ByteString A.Object m a+viewLoop :: MonadIO m => Enumeratee B.ByteString A.Object m a viewLoop (Yield a _) = return $ Yield a EOF viewLoop (Error err) = return $ Error err viewLoop (Continue k) = do @@ -301,7 +302,7 @@ (string "]}" >> return False) <|> return True -- | Enumeratee to parse the data returned by a view.-parseView :: (MonadIO m) => Enumeratee B.ByteString A.Object m a+parseView :: MonadIO m => Enumeratee B.ByteString A.Object m a parseView (Yield a _) = return $ Yield a EOF parseView (Error err) = return $ Error err parseView (Continue k) = do b <- iterParser (viewStart <?> "start of view") @@ -316,5 +317,42 @@ step k (Chunks xs) = case Prelude.mapM f xs of Left err -> throwError err Right xs' -> k (Chunks xs') >>== mapEither f++-- $pool+-- The 'H.Manager' stored in the CouchConnection maintains a pool of open connections in an IORef,+-- but keeps a maximum of one open connection per (host,port) pair.+-- For more precise control over pooling, use the +-- <http://hackage.haskell.org/package/resource-pool> or+-- <http://hackage.haskell.org/package/pool> packages combined with the+-- 'H.newManager' and 'H.closeManager' functions.+--+-- For example, the following code using the resource-pool package runs a /ReaderT CouchConnection m/ action using a+-- HTTP connection from a pool.+-- +-- > runPooledCouch :: MonadCatchIO m+-- > => Pool Manager -> String -> Int -> String -> ReaderT CouchConnection m a -> m a+-- > runPooledCouch p host port dbname c = withResource p $ \m -> do+-- > runReaderT c $ CouchConnection (BU8.fromString host) port m dbname+--+-- A typical use of runPooledCouch in a web server like snap is the following:+--+-- > someSnapDBStuff :: (MonadCouch m, MonadSnap m) => m a+-- > someSnapDBStuff = ...+-- >+-- > mySnap :: MonadSnap m => Pool Manager -> m a+-- > mySnap p = route [ ("/echo/:stuff", echo)+-- > , ("/foo", pooled someSnapDBStuff)+-- > , ("/bar", pooled somethingElse)+-- > ]+-- > where pooled = runPooledCouch p "localhost" 5984 "test"+-- >+-- > launch :: Config Snap () -> IO ()+-- > launch config = do p <- createPool newManager closeManager 1 (fromInteger 10) 100+-- > httpServe config $ mySnap p+--+-- When an incoming connection for the /foo/ path arrives, the /runPooledCouch/ action will be+-- executed. This will pull a manager out of the pool and run the /someSnapDBStuff/ action, returning+-- the manager to the pool once /someSnapDBStuff/ is finished. In this code, each manager will+-- be used by at most one thread at a time so each manager will contain exactly one open HTTP connection. -- vim: set expandtab:set tabstop=4:
couchdb-enumerator.cabal view
@@ -1,5 +1,5 @@ Name: couchdb-enumerator-Version: 0.2.1+Version: 0.3.0 Cabal-Version: >= 1.8 License: BSD3 License-File: LICENSE@@ -38,7 +38,7 @@ , attoparsec-enumerator >= 0.2 && < 0.3 , base >= 4 && < 5 , bytestring >= 0.9 && < 0.10- , containers >= 0.4 && < 0.5+ , containers >= 0.3 && < 0.5 , enumerator >= 0.4 && < 0.5 , http-types >= 0.6 && < 0.7 , http-enumerator >= 0.6.5.3 && < 0.7@@ -58,7 +58,7 @@ , attoparsec-enumerator >= 0.2 && < 0.3 , base >= 4 && < 5 , bytestring >= 0.9 && < 0.10- , containers >= 0.4 && < 0.5+ , containers >= 0.3 && < 0.5 , enumerator >= 0.4 && < 0.5 , http-types >= 0.6 && < 0.7 , http-enumerator >= 0.6.5.3 && < 0.7
tests.hs view
@@ -11,6 +11,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Control (MonadControlIO) import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader import Data.Aeson ((.=)) import qualified Data.Aeson as A import qualified Data.ByteString.UTF8 as BU8@@ -48,8 +49,10 @@ --- Test Helpers ---------------------------------------------------------------------------------- +type CouchT m a = ReaderT CouchConnection m a+ testCouch :: (CouchT IO a) -> IO ()-testCouch c = withCouchConnection "www.wuzzeb.org" 5984 "test" (runCouchT c) >> return ()+testCouch c = withCouchConnection "www.wuzzeb.org" 5984 "test" (runReaderT c) >> return () testCouchCase :: String -> (CouchT IO a) -> Test testCouchCase s c = testCase s $ testCouch c@@ -204,13 +207,13 @@ ] ] -queryByType :: Integer -> Integer -> Integer -> Enumerator A.Object (CouchT IO) b+queryByType :: Integer -> Integer -> Integer -> Enumerator A.Object (ReaderT CouchConnection IO) b queryByType u g t = couchView path query $= extractViewValue where path = "dataviews/_view/bytype" key = "[" ++ show u ++ "," ++ show g ++ "," ++ show t ++ "]" query = [(BU8.fromString "key", Just $ BU8.fromString key)] -queryByGroup :: Integer -> Integer -> Enumerator A.Object (CouchT IO) b+queryByGroup :: Integer -> Integer -> Enumerator A.Object (ReaderT CouchConnection IO) b queryByGroup u g = couchView path query $= extractViewValue where path = "dataviews/_view/bytype" skey = "[" ++ show u ++ "," ++ show g ++ "]"