Permalink
Browse files

Protect implemented

  • Loading branch information...
1 parent b6135a9 commit 887b62cc2e22ed8cf6e45f119ec54714bea1141a @akaspin committed Jan 2, 2012
View
25 LICENSE
@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2011, John Lenz. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
@@ -26,7 +26,9 @@ library
http-types,
text,
attoparsec-conduit,
- blaze-builder
+ blaze-builder,
+ lifted-base,
+ unordered-containers
ghc-options: -Wall
exposed-modules: Database.CouchDB.Conduit
@@ -53,12 +55,11 @@ test-suite test-mock
attoparsec-conduit,
couchdb-conduit,
monad-control,
- blaze-builder
+ blaze-builder,
+ lifted-base,
+ unordered-containers
ghc-options: -Wall -rtsopts
hs-source-dirs: test-mock
main-is: Main.hs
- other-modules:
- Database.CouchDB.Conduit.Test.Connect,
- Database.CouchDB.Conduit.Test.Aeson,
- Database.CouchDB.Conduit.Test.Basic
+ other-modules: Database.CouchDB.Conduit.Test.Basic
@@ -1,25 +1,34 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Database.CouchDB.Conduit where
+import Prelude hiding (catch)
+
-- control
import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
-import Control.Exception (Exception)
+import Control.Exception (Exception, SomeException)
+import Control.Exception.Lifted (catch, throwIO)
import Control.Monad.Trans.Class (lift)
+import Control.Monad.Base (liftBase)
-- conduit
-import Data.Conduit (ResourceIO, ResourceT)
+import Data.Conduit (ResourceIO, ResourceT, ($$))
+import Data.Conduit.Attoparsec (sinkParser)
-- networking
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
-- data
import Data.Typeable (Typeable)
+import Data.Aeson (json, Value(..))
import qualified Data.ByteString as B
+import qualified Data.ByteString.UTF8 as BU8 (toString)
import qualified Data.Text as T
+import qualified Data.HashMap.Lazy as M (lookup)
-- | A path to a CouchDB Object.
--
@@ -83,12 +92,25 @@ couch meth path hdrs qs cons reqBody = do
, H.requestBody = reqBody }
H.http req cons (manager conn)
--- | TODO. Protect response from typical errors like 404, 406 e.t.c.
---
+-- | Protect response from typical errors like 404, 406 e.t.c. Only responses
+-- with codes 200, 201, 202 and 304 are passed.
protect :: ResourceIO m =>
H.ResponseConsumer m b
-> H.ResponseConsumer m b
-protect cons = undefined
+protect c st@(HT.Status 200 _) hdrs bsrc = c st hdrs bsrc
+protect c st@(HT.Status 201 _) hdrs bsrc = c st hdrs bsrc
+protect c st@(HT.Status 202 _) hdrs bsrc = c st hdrs bsrc
+protect c st@(HT.Status 304 _) hdrs bsrc = c st hdrs bsrc
+protect _ (HT.Status sCode sMsg) _ bsrc = do
+ v <- catch (bsrc $$ sinkParser json)
+ (\(_::SomeException) -> return Null)
+ liftBase $ throwIO $ CouchError (Just sCode) $ msg v
+ where
+ msg v = BU8.toString sMsg ++ reason v
+ reason (Object v) = case M.lookup "reason" v of
+ Just (String t) -> ": " ++ T.unpack t
+ _ -> ""
+ reason _ = []
runCouch :: ResourceIO m =>
@@ -1,25 +0,0 @@
--- | tests for aeson
-module Database.CouchDB.Conduit.Test.Aeson where
-
-import Test.Framework (testGroup, Test)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit (Assertion, (@=?))
-
-import Control.Monad.Base (liftBase)
-
-import Data.Conduit
-import Network.HTTP.Conduit
-
-
-tests :: Test
-tests = testGroup "http-conduit" [
- testCase "just iterate" case_basic
- ]
-
-case_basic :: Assertion
-case_basic = do
- request <- parseUrl "http://localhost:5984/"
- runResourceT $ do
- man <- newManager
- Response sc _ _ <- httpLbsRedirect request man
- liftBase $ sc @=? 200
@@ -4,112 +4,104 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Database.CouchDB.Conduit.Test.Basic (tests) where
+import Prelude hiding (catch)
+
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion)
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
-import Control.Monad.Trans.Class
-
import Control.Monad.Base (liftBase)
-import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
+import Control.Exception (SomeException)
+import Control.Exception.Lifted (catch, throwIO)
import Data.Conduit
import Data.Conduit.Attoparsec
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
-
import qualified Data.Text as T
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BU8
-import qualified Blaze.ByteString.Builder as BLB
+import qualified Data.HashMap.Lazy as M
+
+import Database.CouchDB.Conduit
tests :: Test
tests = testGroup "Couch mock" [
-- testCase "Inside couch" case_couchIn,
-- testCase "Outside couch" case_couchOut,
- testCase "Outside couch" case_couchGet
+ testCase "Outside couch" case_couchGet,
+ testCase "Protect" case_couchProtect,
+ testCase "Protect" case_couchProtect404
]
--- | Represents a single connection to CouchDB server.
-data CouchConnection = CouchConnection {
- host :: B.ByteString -- ^ Hostname
- , port :: Int -- ^ Port
- , manager :: H.Manager -- ^ Manager
- , dbname :: B.ByteString -- ^ Database name
-}
-
-class ResourceIO m => MonadCouch m where
- couchConnection :: m CouchConnection
-
-instance ResourceIO m => MonadCouch (ReaderT CouchConnection m) where
- couchConnection = ask
-
case_couchIn :: Assertion
case_couchIn = runCouch "localhost" 5984 "" $ do
- res <- runResourceT $ couch HT.methodGet "" [] [] handlerJ (H.RequestBodyBS B.empty)
+ res <- runResourceT $ couch
+ HT.methodGet "" [] []
+ handlerJ
+ (H.RequestBodyBS B.empty)
liftBase $ print res
case_couchOut :: Assertion
case_couchOut = do
- res <- runCouch "localhost" 5984 "" $ runResourceT $ couch HT.methodGet "" [] [] handlerJ (H.RequestBodyBS B.empty)
+ res <- runCouch "localhost" 5984 "" $ runResourceT $ couch
+ HT.methodGet "" [] []
+ handlerJ
+ (H.RequestBodyBS B.empty)
+ print res
+
+case_couchProtect :: Assertion
+case_couchProtect = do
+ res <- runCouch "localhost" 5984 "" $ runResourceT $ couch
+ HT.methodGet "" [] []
+ (protectT handlerJ)
+ (H.RequestBodyBS B.empty)
+ print res
+
+case_couchProtect404 :: Assertion
+case_couchProtect404 = do
+ res <- runCouch "localhost" 5984 "non_exisi" $ runResourceT $ couch
+ HT.methodGet "" [] []
+ (protectT handlerJ)
+ (H.RequestBodyBS B.empty)
print res
case_couchGet :: Assertion
case_couchGet = do
- res <- runCouch "localhost" 5984 "" $ couchGet "" ""
+ res <- runCouch "localhost" 5984 "" $ couchGetT "" []
print res
handlerJ :: ResourceIO m => H.ResponseConsumer m A.Value
handlerJ _status _hdrs bsrc = bsrc $$ sinkParser A.json
-couchGet :: (MonadCouch m) =>
+couchGetT :: (MonadCouch m) =>
B.ByteString
- -> B.ByteString
+ -> HT.Query
-> m A.Value
-couchGet p q = runResourceT $ couch HT.methodGet p [] [] handlerJ
+couchGetT p q = runResourceT $ couch HT.methodGet p [] q handlerJ
(H.RequestBodyBS B.empty)
-couch :: (MonadCouch m) =>
- HT.Method -- ^ method
- -> B.ByteString -- ^ path
- -> HT.RequestHeaders -- ^ headers
- -> HT.Query
- -> H.ResponseConsumer m b
- -> H.RequestBody m
- -> ResourceT m b
-couch meth path hdrs qs acts reqBody = do
- conn <- lift couchConnection
- let req = H.def
- { H.method = meth
- , H.host = host conn
- , H.requestHeaders = hdrs
- , H.port = port conn
- , H.path = B.intercalate "/" . filter (/="") $ [dbname conn, path]
- , H.queryString = HT.renderQuery False qs
- , H.requestBody = reqBody }
- H.http req acts (manager conn)
-
-runCouch :: ResourceIO m =>
- B.ByteString
- -> Int
- -> B.ByteString
- -> ReaderT CouchConnection m a
- -> m a
-runCouch h p d = withCouchConnection h p d . runReaderT
+protectT :: ResourceIO m =>
+ H.ResponseConsumer m b
+ -> H.ResponseConsumer m b
+protectT c st@(HT.Status 200 _) hdrs bsrc = c st hdrs bsrc
+protectT c st@(HT.Status 201 _) hdrs bsrc = c st hdrs bsrc
+protectT c st@(HT.Status 202 _) hdrs bsrc = c st hdrs bsrc
+protectT c st@(HT.Status 304 _) hdrs bsrc = c st hdrs bsrc
+protectT _ (HT.Status sCode sMsg) _ bsrc = do
+ v <- catch (bsrc $$ sinkParser A.json) (\(_::SomeException) -> return A.Null)
+ liftBase $ throwIO $ CouchError (Just sCode) $ msg v
+ where
+ msg v = BU8.toString sMsg ++ reason v
+ reason (A.Object v) = case M.lookup "reason" v of
+ Just (A.String t) -> ": " ++ T.unpack t
+ _ -> ""
+ reason _ = []
-withCouchConnection :: ResourceIO m =>
- B.ByteString
- -> Int
- -> B.ByteString
- -> (CouchConnection -> m a)
- -> m a
-withCouchConnection h p db f =
- H.withManager $ \m -> lift $ f $ CouchConnection h p m db
@@ -1,34 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
-
-module Database.CouchDB.Conduit.Test.Connect (tests) where
-
-import Test.Framework (testGroup, Test)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit (Assertion)
-
-import Control.Monad.Base (liftBase)
-
-import Data.Aeson as A
-import Data.Conduit
-import Data.Conduit.Attoparsec
-import Network.HTTP.Conduit
-
-
-tests :: Test
-tests = testGroup "http-conduit" [
- testCase "Consumer" case_insideWith
- ]
-
-case_insideWith :: Assertion
-case_insideWith = do
- request <- liftBase $ parseUrl "http://localhost:5984/"
- withManager $ \man -> do
- res <- http request handlerJ man
- liftBase $ print res
-
-
-
---handlerJ _code _hdrs bsrc = bsrc $$ consume
-handlerJ _code _hdrs bsrc = bsrc $$ sinkParser A.json
View
@@ -3,7 +3,6 @@ module Main (main) where
import Test.Framework (defaultMain, Test)
-import qualified Database.CouchDB.Conduit.Test.Connect
import qualified Database.CouchDB.Conduit.Test.Basic
main :: IO ()
@@ -12,7 +11,6 @@ main = defaultMain tests
-- | All tests
tests :: [Test]
tests = [
- Database.CouchDB.Conduit.Test.Connect.tests,
Database.CouchDB.Conduit.Test.Basic.tests
]

0 comments on commit 887b62c

Please sign in to comment.