diff --git a/servant.cabal b/servant.cabal index ed513c58..8968efdd 100644 --- a/servant.cabal +++ b/servant.cabal @@ -29,6 +29,7 @@ library Servant.API.Raw Servant.API.Sub Servant.API.Alternative + Servant.Utils.Client Servant.Utils.Text build-depends: base >=4.7 && <5 diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs index 356b5f7f..c43e4cde 100644 --- a/src/Servant/API/Delete.hs +++ b/src/Servant/API/Delete.hs @@ -1,24 +1,24 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} module Servant.API.Delete where -import Control.Monad -import Control.Monad.IO.Class import Control.Monad.Trans.Either import Data.Proxy import Data.String.Conversions +import Data.Typeable import Network.HTTP.Types import Network.URI import Network.Wai import Servant.Client import Servant.Docs import Servant.Server - -import qualified Network.HTTP.Client as Client +import Servant.Utils.Client -- | Endpoint for DELETE requests. data Delete + deriving Typeable instance HasServer Delete where type Server Delete = EitherT (Int, String) IO () @@ -38,17 +38,8 @@ instance HasServer Delete where instance HasClient Delete where type Client Delete = URIAuth -> EitherT String IO () - clientWithRoute Proxy req host = do - partialRequest <- liftIO $ reqToRequest req host - - let request = partialRequest { Client.method = methodDelete - } - - innerResponse <- liftIO . __withGlobalManager $ \ manager -> - Client.httpLbs request manager - - when (Client.responseStatus innerResponse /= status204) $ - left ("HTTP DELETE request failed with status: " ++ show (Client.responseStatus innerResponse)) + clientWithRoute Proxy req host = + performRequest 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 bc63f3e6..84f15e57 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -1,26 +1,26 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} module Servant.API.Get where -import Control.Monad -import Control.Monad.IO.Class import Control.Monad.Trans.Either import Data.Aeson import Data.Proxy import Data.String.Conversions +import Data.Typeable import Network.HTTP.Types import Network.URI import Network.Wai import Servant.Client import Servant.Docs import Servant.Server - -import qualified Network.HTTP.Client as Client +import Servant.Utils.Client -- | Endpoint for simple GET requests. The server doesn't receive any arguments -- and serves the contained type as JSON. data Get a + deriving Typeable instance ToJSON result => HasServer (Get result) where type Server (Get result) = EitherT (Int, String) IO result @@ -38,15 +38,8 @@ instance ToJSON result => HasServer (Get result) where instance FromJSON result => HasClient (Get result) where type Client (Get result) = URIAuth -> EitherT String IO result - clientWithRoute Proxy req host = do - innerRequest <- liftIO $ reqToRequest req host - - innerResponse <- liftIO $ __withGlobalManager $ \ manager -> - Client.httpLbs innerRequest manager - when (Client.responseStatus innerResponse /= ok200) $ - left ("HTTP GET request failed with status: " ++ show (Client.responseStatus innerResponse)) - maybe (left "HTTP GET request returned invalid json") return $ - decode' (Client.responseBody innerResponse) + clientWithRoute Proxy req host = + performRequest 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 bdb04e52..b67c05d6 100644 --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -1,27 +1,27 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} module Servant.API.Post where -import Control.Monad -import Control.Monad.IO.Class import Control.Monad.Trans.Either import Data.Aeson import Data.Proxy import Data.String.Conversions +import Data.Typeable import Network.HTTP.Types import Network.URI import Network.Wai import Servant.Client import Servant.Docs import Servant.Server - -import qualified Network.HTTP.Client as Client +import Servant.Utils.Client -- | Endpoint for POST requests. The type variable represents the type of the -- response body (not the request body, use 'Servant.API.RQBody.RQBody' for -- that). data Post a + deriving Typeable instance ToJSON a => HasServer (Post a) where type Server (Post a) = EitherT (Int, String) IO a @@ -41,20 +41,8 @@ instance ToJSON a => HasServer (Post a) where instance FromJSON a => HasClient (Post a) where type Client (Post a) = URIAuth -> EitherT String IO a - clientWithRoute Proxy req uri = do - partialRequest <- liftIO $ reqToRequest req uri - - let request = partialRequest { Client.method = methodPost - } - - innerResponse <- liftIO . __withGlobalManager $ \ manager -> - Client.httpLbs request manager - - when (Client.responseStatus innerResponse /= status201) $ - left ("HTTP POST request failed with status: " ++ show (Client.responseStatus innerResponse)) - - maybe (left "HTTP POST request returned invalid json") return $ - decode' (Client.responseBody innerResponse) + clientWithRoute Proxy req uri = + performRequest 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 0a10ae25..54e8fdae 100644 --- a/src/Servant/API/Put.hs +++ b/src/Servant/API/Put.hs @@ -1,25 +1,25 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} module Servant.API.Put where -import Control.Monad -import Control.Monad.IO.Class import Control.Monad.Trans.Either import Data.Aeson import Data.Proxy import Data.String.Conversions +import Data.Typeable import Network.HTTP.Types import Network.URI import Network.Wai import Servant.Client import Servant.Docs import Servant.Server - -import qualified Network.HTTP.Client as Client +import Servant.Utils.Client -- | Endpoint for PUT requests. data Put a + deriving Typeable instance ToJSON a => HasServer (Put a) where type Server (Put a) = EitherT (Int, String) IO a @@ -40,20 +40,8 @@ instance ToJSON a => HasServer (Put a) where instance FromJSON a => HasClient (Put a) where type Client (Put a) = URIAuth -> EitherT String IO a - clientWithRoute Proxy req uri = do - partialRequest <- liftIO $ reqToRequest req uri - - let request = partialRequest { Client.method = methodPut - } - - innerResponse <- liftIO . __withGlobalManager $ \ manager -> - Client.httpLbs request manager - - when (Client.responseStatus innerResponse /= ok200) $ - left ("HTTP PUT request failed with status: " ++ show (Client.responseStatus innerResponse)) - - maybe (left "HTTP PUT request returned invalid json") return $ - decode' (Client.responseBody innerResponse) + clientWithRoute Proxy req host = + performRequest methodPut req 200 host instance ToSample a => HasDocs (Put a) where docsFor Proxy (endpoint, action) = diff --git a/src/Servant/Utils/Client.hs b/src/Servant/Utils/Client.hs new file mode 100644 index 00000000..b6a71e9b --- /dev/null +++ b/src/Servant/Utils/Client.hs @@ -0,0 +1,48 @@ +module Servant.Utils.Client where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.Aeson +import Data.String.Conversions +import Network.HTTP.Types +import Network.URI +import Servant.Client + +import qualified Network.HTTP.Client as Client + +performRequest :: FromJSON result => + Method -> Req -> Int -> URIAuth -> EitherT String IO result +performRequest method req wantedStatus host = do + partialRequest <- liftIO $ reqToRequest req host + + let request = partialRequest { Client.method = method + } + + eResponse <- liftIO $ __withGlobalManager $ \ manager -> + catchStatusCodeException $ + Client.httpLbs request manager + case eResponse of + Left status -> + left (requestString ++ " 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 <- maybe (left (requestString ++ " returned invalid json")) return $ + decode' (Client.responseBody response) + return result + where + requestString = "HTTP " ++ cs method ++ " request" + showStatus (Status code message) = + show code ++ " - " ++ cs message + +catchStatusCodeException :: IO a -> IO (Either Status a) +catchStatusCodeException action = catch (Right <$> action) $ + \ e -> case e of + Client.StatusCodeException status _ _ -> + return $ Left status + e -> throwIO e diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index ead73e61..98e4022f 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ViewPatterns #-} module Servant.ClientSpec where @@ -7,6 +9,7 @@ import Control.Concurrent import Control.Exception import Control.Monad.Trans.Either import Data.Proxy +import Data.Typeable import Network.Socket import Network.URI import Network.Wai @@ -23,6 +26,7 @@ type Api = "get" :> Get Person :<|> "capture" :> Capture "name" String :> Get Person :<|> "body" :> ReqBody Person :> Post Person + :<|> "param" :> QueryParam "name" String :> Get Person api :: Proxy Api api = Proxy @@ -31,6 +35,10 @@ server = serve api ( return alice :<|> (\ name -> return $ Person name 0) :<|> return + :<|> (\ name -> case name of + Just "alice" -> return alice + Just name -> left (400, name ++ " not found") + Nothing -> left (400, "missing parameter")) ) withServer :: (URIAuth -> IO a) -> IO a @@ -39,7 +47,8 @@ withServer action = withWaiDaemon (return server) (action . mkHost "localhost") getGet :: URIAuth -> EitherT String IO Person getCapture :: String -> URIAuth -> EitherT String IO Person getBody :: Person -> URIAuth -> EitherT String IO Person -(getGet :<|> getCapture :<|> getBody) = client api +getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person +(getGet :<|> getCapture :<|> getBody :<|> getQueryParam) = client api spec :: Spec spec = do @@ -53,6 +62,34 @@ spec = do let p = Person "Clara" 42 runEitherT (getBody p host) `shouldReturn` Right p + it "Servant.API.QueryParam" $ withServer $ \ host -> do + runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice + Left result <- runEitherT (getQueryParam (Just "bob") host) + result `shouldContain` "bob not found" + + context "client correctly handles error status codes" $ do + let test :: WrappedApi -> Spec + test (WrappedApi api) = + it (show (typeOf api)) $ + withWaiDaemon (return (serve api (left (500, "error message")))) $ + \ (mkHost "localhost" -> host) -> do + let getResponse :: URIAuth -> EitherT String IO () + getResponse = client api + Left result <- runEitherT (getResponse host) + result `shouldContain` "error message" + mapM_ test $ + (WrappedApi (Proxy :: Proxy Delete)) : + (WrappedApi (Proxy :: Proxy (Get ()))) : + (WrappedApi (Proxy :: Proxy (Post ()))) : + (WrappedApi (Proxy :: Proxy (Put ()))) : + [] + +data WrappedApi where + WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a, + HasClient api, Client api ~ (URIAuth -> EitherT String IO ()), + Typeable api) => + Proxy api -> WrappedApi + -- * utils