From eff31f748514a122fe31c3be5b9a542f700d1b43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?S=C3=B6nke=20Hahn?= Date: Thu, 13 Nov 2014 19:57:53 +0800 Subject: [PATCH] implemented 'instance HasClient Raw' --- src/Servant/API/Delete.hs | 2 +- src/Servant/API/Get.hs | 2 +- src/Servant/API/Post.hs | 2 +- src/Servant/API/Put.hs | 2 +- src/Servant/API/Raw.hs | 19 +++++++++++++++++-- src/Servant/Common/Req.hs | 34 ++++++++++++++++++++++------------ test/Servant/ClientSpec.hs | 13 ++++++++++++- 7 files changed, 55 insertions(+), 19 deletions(-) diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs index 80b78e44..7355615f 100644 --- a/src/Servant/API/Delete.hs +++ b/src/Servant/API/Delete.hs @@ -39,7 +39,7 @@ instance HasClient Delete where type Client Delete = BaseUrl -> EitherT String IO () clientWithRoute Proxy req host = - performRequest methodDelete req 204 host + performRequestJSON methodDelete req 204 host instance HasDocs Delete where docsFor Proxy (endpoint, action) = diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs index c6d375b0..e1ac36ef 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -39,7 +39,7 @@ instance ToJSON result => HasServer (Get result) where instance FromJSON result => HasClient (Get result) where type Client (Get result) = BaseUrl -> EitherT String IO result clientWithRoute Proxy req host = - performRequest methodGet req 200 host + performRequestJSON methodGet req 200 host instance ToSample a => HasDocs (Get a) where docsFor Proxy (endpoint, action) = diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs index 2a4a4feb..c646720c 100644 --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -42,7 +42,7 @@ instance FromJSON a => HasClient (Post a) where type Client (Post a) = BaseUrl -> EitherT String IO a clientWithRoute Proxy req uri = - performRequest methodPost req 201 uri + performRequestJSON methodPost req 201 uri instance ToSample a => HasDocs (Post a) where docsFor Proxy (endpoint, action) = diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs index 5c71097c..3ef2c17f 100644 --- a/src/Servant/API/Put.hs +++ b/src/Servant/API/Put.hs @@ -41,7 +41,7 @@ instance FromJSON a => HasClient (Put a) where type Client (Put a) = BaseUrl -> EitherT String IO a clientWithRoute Proxy req host = - performRequest methodPut req 200 host + performRequestJSON methodPut req 200 host instance ToSample a => HasDocs (Put a) where docsFor Proxy (endpoint, action) = diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs index 27e43063..644ccb62 100644 --- a/src/Servant/API/Raw.hs +++ b/src/Servant/API/Raw.hs @@ -1,10 +1,17 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Servant.API.Raw where +import Control.Monad.Trans.Either +import Data.ByteString.Lazy import Data.Proxy +import Network.HTTP.Types import Network.Wai -import Servant.Docs +import Servant.Client +import Servant.Common.BaseUrl +import Servant.Common.Req +import Servant.Docs hiding (Method) import Servant.Server -- | Endpoint for plugging in your own Wai 'Application's. @@ -18,6 +25,14 @@ instance HasServer Raw where route Proxy rawApplication request respond = rawApplication request (respond . succeedWith) +instance HasClient Raw where + type Client Raw = Method -> BaseUrl -> EitherT String IO ByteString + + clientWithRoute :: Proxy Raw -> Req -> Client Raw + clientWithRoute Proxy req method host = + performRequest method req (const True) host + + instance HasDocs Raw where docsFor _proxy (endpoint, action) = single endpoint action diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index bff9c393..363b92c9 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -77,9 +77,13 @@ __withGlobalManager action = modifyMVar __manager $ \ manager -> do result <- action manager return (manager, result) -performRequest :: FromJSON result => - Method -> Req -> Int -> BaseUrl -> EitherT String IO result -performRequest method req wantedStatus host = do + +displayHttpRequest :: Method -> String +displayHttpRequest method = "HTTP " ++ cs method ++ " request" + + +performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO ByteString +performRequest method req isWantedStatus host = do partialRequest <- liftIO $ reqToRequest req host let request = partialRequest { Client.method = method @@ -90,22 +94,28 @@ performRequest method req wantedStatus host = do Client.httpLbs request manager case eResponse of Left status -> - left (requestString ++ " failed with status: " ++ showStatus status) + left (displayHttpRequest method ++ " failed with status: " ++ showStatus status) Right response -> do let status = Client.responseStatus response - when (statusCode status /= wantedStatus) $ - left (requestString ++ " failed with status: " ++ showStatus status) - result <- either - (\ message -> left (requestString ++ " returned invalid json: " ++ message)) - return - (decodeLenient (Client.responseBody response)) - return result + unless (isWantedStatus (statusCode status)) $ + left (displayHttpRequest method ++ " failed with status: " ++ showStatus status) + return $ Client.responseBody response where - requestString = "HTTP " ++ cs method ++ " request" showStatus (Status code message) = show code ++ " - " ++ cs message + +performRequestJSON :: FromJSON result => + Method -> Req -> Int -> BaseUrl -> EitherT String IO result +performRequestJSON method req wantedStatus host = do + responseBody <- performRequest method req (== wantedStatus) host + either + (\ message -> left (displayHttpRequest method ++ " returned invalid json: " ++ message)) + return + (decodeLenient responseBody) + + catchStatusCodeException :: IO a -> IO (Either Status a) catchStatusCodeException action = catch (Right <$> action) $ \ e -> case e of diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index 2744b6ed..37765369 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module Servant.ClientSpec where @@ -8,10 +9,12 @@ module Servant.ClientSpec where import Control.Concurrent import Control.Exception import Control.Monad.Trans.Either +import Data.ByteString.Lazy (ByteString) import Data.Char import Data.Foldable (forM_) import Data.Proxy import Data.Typeable +import Network.HTTP.Types import Network.Socket import Network.Wai import Network.Wai.Handler.Warp @@ -33,6 +36,8 @@ type Api = :<|> "param" :> QueryParam "name" String :> Get Person :<|> "params" :> QueryParams "names" String :> Get [Person] :<|> "flag" :> QueryFlag "flag" :> Get Bool + :<|> "rawSuccess" :> Raw + :<|> "rawFailure" :> Raw :<|> "multiple" :> Capture "first" String :> QueryParam "second" Int :> @@ -53,6 +58,8 @@ server = serve api ( Nothing -> left (400, "missing parameter")) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return + :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") + :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> \ a b c d -> return (a, b, c, d) ) @@ -65,6 +72,8 @@ getBody :: Person -> BaseUrl -> EitherT String IO Person getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person] getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool +getRawSuccess :: Method -> BaseUrl -> EitherT String IO ByteString +getRawFailure :: Method -> BaseUrl -> EitherT String IO ByteString getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> BaseUrl -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])]) @@ -74,6 +83,8 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] :<|> getQueryParam :<|> getQueryParams :<|> getQueryFlag + :<|> getRawSuccess + :<|> getRawFailure :<|> getMultiple) = client api