diff --git a/Database/CouchDB/Enumerator.hs b/Database/CouchDB/Enumerator.hs --- a/Database/CouchDB/Enumerator.hs +++ b/Database/CouchDB/Enumerator.hs @@ -84,6 +84,7 @@ import Control.Monad.Trans.Class (MonadTrans, lift) import Control.Monad.Trans.Reader (ReaderT, ask) import qualified Data.Aeson as A +import qualified Data.Aeson.Encode as AE import Data.Attoparsec import Data.Attoparsec.Enumerator (iterParser) import qualified Data.ByteString as B @@ -150,18 +151,13 @@ -> 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 $ error "no cert checking" - , H.host = host conn - , H.port = port conn - , H.path = BU8.fromString ("/" ++ dbname conn ++ "/" ++ p) - , H.queryString = q - , H.requestHeaders = [] - , H.requestBody = b - , H.proxy = Nothing - , H.rawBody = False - } + let req = H.def { H.method = m + , H.host = host conn + , H.port = port conn + , H.path = BU8.fromString ("/" ++ dbname conn ++ "/" ++ p) + , H.queryString = q + , H.requestBody = b + } runIteratee $ H.http req (\s _ -> checkStatus s i) (manager conn) -- | Load a single object from couch DB. @@ -180,7 +176,7 @@ -> m Revision couchPut p q val = do v <- run_ $ couch HT.methodPut p q (iterParser A.json) body either (liftIO . throw) return (valToObj v >>= objToRev) - where body = H.RequestBodyLBS $ A.encode $ A.toJSON val + where body = jsonToReqBody val -- | A version of 'couchPut' which ignores the return value. This is slightly faster than / _ <- couchPut .../ -- since the JSON parser is not run. @@ -190,7 +186,7 @@ -> a -- ^ The object to store. -> m () couchPut_ p q val = run_ $ couch HT.methodPut p q (yield () EOF) body - where body = H.RequestBodyLBS $ A.encode $ A.toJSON val + where body = jsonToReqBody val -- | Delete the given revision of the object. couchDelete :: MonadCouch m @@ -238,6 +234,13 @@ ----------------------------------------------------------------------------------------- --- Helper Code ----------------------------------------------------------------------------------------- + +-- | Converts a json object into a 'H.RequestBodyEnumChunked' +jsonToReqBody :: (A.ToJSON a, Monad m) => a -> H.RequestBody m +jsonToReqBody val = H.RequestBodyEnumChunked enum + where jbuilder = AE.fromValue $ A.toJSON val + enum (Continue k) = k (Chunks [jbuilder]) + enum step = returnI step -- | Check status codes from couch db. checkStatus :: Monad m => HT.Status -> Iteratee B.ByteString m b diff --git a/couchdb-enumerator.cabal b/couchdb-enumerator.cabal --- a/couchdb-enumerator.cabal +++ b/couchdb-enumerator.cabal @@ -1,5 +1,5 @@ Name: couchdb-enumerator -Version: 0.3.0 +Version: 0.3.1 Cabal-Version: >= 1.8 License: BSD3 License-File: LICENSE @@ -41,7 +41,7 @@ , containers >= 0.3 && < 0.5 , enumerator >= 0.4 && < 0.5 , http-types >= 0.6 && < 0.7 - , http-enumerator >= 0.6.5.3 && < 0.7 + , http-enumerator >= 0.7 && < 0.8 , monad-control >= 0.2 && < 0.3 , text >= 0.11 && < 0.12 , transformers >= 0.2 && < 0.3 @@ -61,7 +61,7 @@ , containers >= 0.3 && < 0.5 , enumerator >= 0.4 && < 0.5 , http-types >= 0.6 && < 0.7 - , http-enumerator >= 0.6.5.3 && < 0.7 + , http-enumerator >= 0.7 && < 0.8 , monad-control >= 0.2 && < 0.3 , text >= 0.11 && < 0.12 , transformers >= 0.2 && < 0.3 diff --git a/tests.hs b/tests.hs --- a/tests.hs +++ b/tests.hs @@ -17,8 +17,7 @@ import qualified Data.ByteString.UTF8 as BU8 import Data.Enumerator hiding (map, length, head, run, drop) import qualified Data.Enumerator.List as EL -import Data.List (find, deleteBy) -import Data.List (nubBy) +import Data.List (find, deleteBy, nubBy) import qualified Data.Map as M import Data.Maybe (fromJust) import qualified Data.Text as T @@ -51,10 +50,10 @@ type CouchT m a = ReaderT CouchConnection m a -testCouch :: (CouchT IO a) -> IO () -testCouch c = withCouchConnection "www.wuzzeb.org" 5984 "test" (runReaderT c) >> return () +testCouch :: CouchT IO a -> IO () +testCouch c = withCouchConnection "server" 5984 "test" (runReaderT c) >> return () -testCouchCase :: String -> (CouchT IO a) -> Test +testCouchCase :: String -> CouchT IO a -> Test testCouchCase s c = testCase s $ testCouch c testCouchProperty :: (Show a, Arbitrary a) => String -> (Int,Int) -> ([a] -> CouchT IO b) -> Test @@ -65,9 +64,7 @@ -- | Assert that the value is a string, and check that it matches the given string assertStr :: T.Text -> A.Value -> Assertion -assertStr t (A.String t') = if t == t' - then return () - else assertFailure $ "strings are not equal. expecting " +assertStr t (A.String t') = unless (t == t') $ assertFailure $ "strings are not equal. expecting " ++ T.unpack t ++ " received " ++ T.unpack t' assertStr _ _ = assertFailure "expecting a JSON string" @@ -80,7 +77,7 @@ -- | Expect a couch error with the given code assertRecvError :: (MonadControlIO m) => Maybe Int -> m a -> m () assertRecvError code v = go `catch` \(CouchError c _) -> liftIO (code @=? c) - where go = v >> (liftIO $ assertFailure "was expecting a couch error") + where go = v >> liftIO (assertFailure "was expecting a couch error") -- | Check that an object in the database matches the given value. checkLoad :: String -> A.Object -> CouchT IO () @@ -90,9 +87,9 @@ -- | Delete the given object, useful for the start of a test clearObject :: String -> CouchT IO () -clearObject n = go `catch` \(e@(CouchError i _)) -> if i == Just 404 then return () else throwIO e +clearObject n = go `catch` \(e@(CouchError i _)) -> unless (i == Just 404) $ throwIO e where go = do obj <- couchGet n [] - when (not $ M.member "_rev" obj) $ fail "_rev is missing" + unless (M.member "_rev" obj) $ fail "_rev is missing" let (A.String rev) = fromJust $ M.lookup "_rev" obj couchDelete n rev @@ -141,15 +138,14 @@ lift $ assertObjMember "db_name" (assertStr "test") v missingObjectTest :: CouchT IO () -missingObjectTest = do - assertRecvError (Just 404) $ couchGet "jaosihaweoghaweiouhawef" [] +missingObjectTest = assertRecvError (Just 404) $ couchGet "jaosihaweoghaweiouhawef" [] insertTest :: [(Int,ArbitraryObject,ArbitraryObject)] -> CouchT IO () insertTest objs = do let objs' = nubBy (\(a,_,_) (b,_,_) -> a == b) objs let keys = map (("otest"++) . show . (\(a,_,_) -> a)) objs' - let vals1 = map (\(_,(ArbitraryObject a),_) -> a) objs' - let vals2 = map (\(_,_,(ArbitraryObject a)) -> a) objs' + let vals1 = map (\(_,ArbitraryObject a,_) -> a) objs' + let vals2 = map (\(_,_,ArbitraryObject a) -> a) objs' mapM_ clearObject keys @@ -157,7 +153,7 @@ forM_ (zip3 rev keys vals1) $ \(r,k,o) -> checkLoad k $ M.insert "_rev" (A.toJSON r) o - rev2 <- forM (zip3 rev keys vals2) $ \(r,k,o) -> do + rev2 <- forM (zip3 rev keys vals2) $ \(r,k,o) -> couchPut k [] $ M.insert "_rev" (A.toJSON r) o forM_ (zip3 rev2 keys vals2) $ \(r,k,o) -> @@ -195,7 +191,7 @@ ] addView :: CouchT IO () -addView = couchPut_ "_design/dataviews" [] $ viewObj where +addView = couchPut_ "_design/dataviews" [] viewObj where viewObj = A.object [ "language" .= ("javascript" :: T.Text) , "views" .= A.object @@ -240,7 +236,7 @@ mapM_ clearObject $ g1key ++ g2key ++ g3key ++ g4key - addView `catch` \e@(CouchError c _) -> if c == Just 409 then return () else throwIO e + addView `catch` \e@(CouchError c _) -> unless (c == Just 409) $ throwIO e forM_ (zip g1key g1obj ++ zip g2key g2obj ++ zip g3key g3obj ++ zip g4key g4obj) $ \(k,o) -> couchPut_ k [] o