a9eeff1 · typeable/servant

servant.cabal+1

compare with master

unifiedsplit

@@ -29,6 +29,7 @@ library

29 Servant.API.Raw

30 Servant.API.Sub

31 Servant.API.Alternative

32+ Servant.Utils.Client

32 Servant.Utils.Text

33 Servant.Utils.Text

33 build-depends:

34 build-depends:

34 base >=4.7 && <5

35 base >=4.7 && <5

src/Servant/API/Delete.hs+6−15

@@ -1,24 +1,24 @@

1{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE DeriveDataTypeable #-}

4module Servant.API.Delete where

5module Servant.API.Delete where

5

6

6−import Control.Monad

7−import Control.Monad.IO.Class

8import Control.Monad.Trans.Either

7import Control.Monad.Trans.Either

9import Data.Proxy

8import Data.Proxy

10import Data.String.Conversions

9import Data.String.Conversions

10+import Data.Typeable

11import Network.HTTP.Types

12import Network.URI

13import Network.Wai

14import Servant.Client

15import Servant.Docs

16import Servant.Server

17−

17+import Servant.Utils.Client

18−import qualified Network.HTTP.Client as Client

19

18

20-- | Endpoint for DELETE requests.

19-- | Endpoint for DELETE requests.

21data Delete

20data Delete

21+ deriving Typeable

22

23instance HasServer Delete where

24 type Server Delete = EitherT (Int, String) IO ()

@@ -38,17 +38,8 @@ instance HasServer Delete where

38instance HasClient Delete where

39 type Client Delete = URIAuth -> EitherT String IO ()

40

41− clientWithRoute Proxy req host = do

41+ clientWithRoute Proxy req host =

42− partialRequest <- liftIO $ reqToRequest req host

42+ performRequest methodDelete req 204 host

43−

44− let request = partialRequest { Client.method = methodDelete

45− }

46−

47− innerResponse <- liftIO . __withGlobalManager $ \ manager ->

48− Client.httpLbs request manager

49−

50− when (Client.responseStatus innerResponse /= status204) $

51− left ("HTTP DELETE request failed with status: " ++ show (Client.responseStatus innerResponse))

52

43

53instance HasDocs Delete where

44instance HasDocs Delete where

54 docsFor Proxy (endpoint, action) =

45 docsFor Proxy (endpoint, action) =

src/Servant/API/Get.hs+6−13

@@ -1,26 +1,26 @@

1{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE DeriveDataTypeable #-}

4module Servant.API.Get where

5module Servant.API.Get where

5

6

6−import Control.Monad

7−import Control.Monad.IO.Class

8import Control.Monad.Trans.Either

7import Control.Monad.Trans.Either

9import Data.Aeson

8import Data.Aeson

10import Data.Proxy

9import Data.Proxy

11import Data.String.Conversions

10import Data.String.Conversions

11+import Data.Typeable

12import Network.HTTP.Types

13import Network.URI

14import Network.Wai

15import Servant.Client

16import Servant.Docs

17import Servant.Server

18−

18+import Servant.Utils.Client

19−import qualified Network.HTTP.Client as Client

20

19

21-- | Endpoint for simple GET requests. The server doesn't receive any arguments

20-- | Endpoint for simple GET requests. The server doesn't receive any arguments

22-- and serves the contained type as JSON.

21-- and serves the contained type as JSON.

23data Get a

22data Get a

23+ deriving Typeable

24

25instance ToJSON result => HasServer (Get result) where

26 type Server (Get result) = EitherT (Int, String) IO result

@@ -38,15 +38,8 @@ instance ToJSON result => HasServer (Get result) where

38

39instance FromJSON result => HasClient (Get result) where

40 type Client (Get result) = URIAuth -> EitherT String IO result

41− clientWithRoute Proxy req host = do

41+ clientWithRoute Proxy req host =

42− innerRequest <- liftIO $ reqToRequest req host

42+ performRequest methodGet req 200 host

43−

44− innerResponse <- liftIO $ __withGlobalManager $ \ manager ->

45− Client.httpLbs innerRequest manager

46− when (Client.responseStatus innerResponse /= ok200) $

47− left ("HTTP GET request failed with status: " ++ show (Client.responseStatus innerResponse))

48− maybe (left "HTTP GET request returned invalid json") return $

49− decode' (Client.responseBody innerResponse)

50

43

51instance ToSample a => HasDocs (Get a) where

44instance ToSample a => HasDocs (Get a) where

52 docsFor Proxy (endpoint, action) =

45 docsFor Proxy (endpoint, action) =

src/Servant/API/Post.hs+6−18

@@ -1,27 +1,27 @@

1{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE DeriveDataTypeable #-}

4module Servant.API.Post where

5module Servant.API.Post where

5

6

6−import Control.Monad

7−import Control.Monad.IO.Class

8import Control.Monad.Trans.Either

7import Control.Monad.Trans.Either

9import Data.Aeson

8import Data.Aeson

10import Data.Proxy

9import Data.Proxy

11import Data.String.Conversions

10import Data.String.Conversions

11+import Data.Typeable

12import Network.HTTP.Types

13import Network.URI

14import Network.Wai

15import Servant.Client

16import Servant.Docs

17import Servant.Server

18−

18+import Servant.Utils.Client

19−import qualified Network.HTTP.Client as Client

20

19

21-- | Endpoint for POST requests. The type variable represents the type of the

20-- | Endpoint for POST requests. The type variable represents the type of the

22-- response body (not the request body, use 'Servant.API.RQBody.RQBody' for

21-- response body (not the request body, use 'Servant.API.RQBody.RQBody' for

23-- that).

22-- that).

24data Post a

23data Post a

24+ deriving Typeable

25

26instance ToJSON a => HasServer (Post a) where

27 type Server (Post a) = EitherT (Int, String) IO a

@@ -41,20 +41,8 @@ instance ToJSON a => HasServer (Post a) where

41instance FromJSON a => HasClient (Post a) where

42 type Client (Post a) = URIAuth -> EitherT String IO a

43

44− clientWithRoute Proxy req uri = do

44+ clientWithRoute Proxy req uri =

45− partialRequest <- liftIO $ reqToRequest req uri

45+ performRequest methodPost req 201 uri

46−

47− let request = partialRequest { Client.method = methodPost

48− }

49−

50− innerResponse <- liftIO . __withGlobalManager $ \ manager ->

51− Client.httpLbs request manager

52−

53− when (Client.responseStatus innerResponse /= status201) $

54− left ("HTTP POST request failed with status: " ++ show (Client.responseStatus innerResponse))

55−

56− maybe (left "HTTP POST request returned invalid json") return $

57− decode' (Client.responseBody innerResponse)

58

46

59instance ToSample a => HasDocs (Post a) where

47instance ToSample a => HasDocs (Post a) where

60 docsFor Proxy (endpoint, action) =

48 docsFor Proxy (endpoint, action) =

src/Servant/API/Put.hs+6−18

@@ -1,25 +1,25 @@

1{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE DeriveDataTypeable #-}

4module Servant.API.Put where

5module Servant.API.Put where

5

6

6−import Control.Monad

7−import Control.Monad.IO.Class

8import Control.Monad.Trans.Either

7import Control.Monad.Trans.Either

9import Data.Aeson

8import Data.Aeson

10import Data.Proxy

9import Data.Proxy

11import Data.String.Conversions

10import Data.String.Conversions

11+import Data.Typeable

12import Network.HTTP.Types

13import Network.URI

14import Network.Wai

15import Servant.Client

16import Servant.Docs

17import Servant.Server

18−

18+import Servant.Utils.Client

19−import qualified Network.HTTP.Client as Client

20

19

21-- | Endpoint for PUT requests.

20-- | Endpoint for PUT requests.

22data Put a

21data Put a

22+ deriving Typeable

23

24instance ToJSON a => HasServer (Put a) where

25 type Server (Put a) = EitherT (Int, String) IO a

@@ -40,20 +40,8 @@ instance ToJSON a => HasServer (Put a) where

40instance FromJSON a => HasClient (Put a) where

41 type Client (Put a) = URIAuth -> EitherT String IO a

42

43− clientWithRoute Proxy req uri = do

43+ clientWithRoute Proxy req host =

44− partialRequest <- liftIO $ reqToRequest req uri

44+ performRequest methodPut req 200 host

45−

46− let request = partialRequest { Client.method = methodPut

47− }

48−

49− innerResponse <- liftIO . __withGlobalManager $ \ manager ->

50− Client.httpLbs request manager

51−

52− when (Client.responseStatus innerResponse /= ok200) $

53− left ("HTTP PUT request failed with status: " ++ show (Client.responseStatus innerResponse))

54−

55− maybe (left "HTTP PUT request returned invalid json") return $

56− decode' (Client.responseBody innerResponse)

57

45

58instance ToSample a => HasDocs (Put a) where

46instance ToSample a => HasDocs (Put a) where

59 docsFor Proxy (endpoint, action) =

47 docsFor Proxy (endpoint, action) =

src/Servant/Utils/Client.hsnew file+48

@@ -0,0 +1,48 @@

1+module Servant.Utils.Client where

2+

3+import Control.Applicative

4+import Control.Exception

5+import Control.Monad

6+import Control.Monad.IO.Class

7+import Control.Monad.Trans.Either

8+import Data.Aeson

9+import Data.String.Conversions

10+import Network.HTTP.Types

11+import Network.URI

12+import Servant.Client

13+

14+import qualified Network.HTTP.Client as Client

15+

16+performRequest :: FromJSON result =>

17+ Method -> Req -> Int -> URIAuth -> EitherT String IO result

18+performRequest method req wantedStatus host = do

19+ partialRequest <- liftIO $ reqToRequest req host

20+

21+ let request = partialRequest { Client.method = method

22+ }

23+

24+ eResponse <- liftIO $ __withGlobalManager $ \ manager ->

25+ catchStatusCodeException $

26+ Client.httpLbs request manager

27+ case eResponse of

28+ Left status ->

29+ left (requestString ++ " failed with status: " ++ showStatus status)

30+

31+ Right response -> do

32+ let status = Client.responseStatus response

33+ when (statusCode status /= wantedStatus) $

34+ left (requestString ++ " failed with status: " ++ showStatus status)

35+ result <- maybe (left (requestString ++ " returned invalid json")) return $

36+ decode' (Client.responseBody response)

37+ return result

38+ where

39+ requestString = "HTTP " ++ cs method ++ " request"

40+ showStatus (Status code message) =

41+ show code ++ " - " ++ cs message

42+

43+catchStatusCodeException :: IO a -> IO (Either Status a)

44+catchStatusCodeException action = catch (Right <$> action) $

45+ \ e -> case e of

46+ Client.StatusCodeException status _ _ ->

47+ return $ Left status

48+ e -> throwIO e

test/Servant/ClientSpec.hs+38−1

@@ -1,5 +1,7 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE ViewPatterns #-}

3

5

4module Servant.ClientSpec where

6module Servant.ClientSpec where

5

7

@@ -7,6 +9,7 @@ import Control.Concurrent

7import Control.Exception

9import Control.Exception

8import Control.Monad.Trans.Either

10import Control.Monad.Trans.Either

9import Data.Proxy

11import Data.Proxy

12+import Data.Typeable

10import Network.Socket

13import Network.Socket

11import Network.URI

14import Network.URI

12import Network.Wai

15import Network.Wai

@@ -23,6 +26,7 @@ type Api =

23 "get" :> Get Person

26 "get" :> Get Person

24 :<|> "capture" :> Capture "name" String :> Get Person

27 :<|> "capture" :> Capture "name" String :> Get Person

25 :<|> "body" :> ReqBody Person :> Post Person

28 :<|> "body" :> ReqBody Person :> Post Person

29+ :<|> "param" :> QueryParam "name" String :> Get Person

26api :: Proxy Api

30api :: Proxy Api

27api = Proxy

31api = Proxy

28

32

@@ -31,6 +35,10 @@ server = serve api (

31 return alice

35 return alice

32 :<|> (\ name -> return $ Person name 0)

36 :<|> (\ name -> return $ Person name 0)

33 :<|> return

37 :<|> return

38+ :<|> (\ name -> case name of

39+ Just "alice" -> return alice

40+ Just name -> left (400, name ++ " not found")

41+ Nothing -> left (400, "missing parameter"))

34 )

42 )

35

43

36withServer :: (URIAuth -> IO a) -> IO a

44withServer :: (URIAuth -> IO a) -> IO a

@@ -39,7 +47,8 @@ withServer action = withWaiDaemon (return server) (action . mkHost "localhost")

39getGet :: URIAuth -> EitherT String IO Person

47getGet :: URIAuth -> EitherT String IO Person

40getCapture :: String -> URIAuth -> EitherT String IO Person

48getCapture :: String -> URIAuth -> EitherT String IO Person

41getBody :: Person -> URIAuth -> EitherT String IO Person

49getBody :: Person -> URIAuth -> EitherT String IO Person

50+getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person

42−(getGet :<|> getCapture :<|> getBody) = client api

51+(getGet :<|> getCapture :<|> getBody :<|> getQueryParam) = client api

43

52

44spec :: Spec

53spec :: Spec

45spec = do

54spec = do

@@ -53,6 +62,34 @@ spec = do

53 let p = Person "Clara" 42

62 let p = Person "Clara" 42

54 runEitherT (getBody p host) `shouldReturn` Right p

63 runEitherT (getBody p host) `shouldReturn` Right p

55

64

65+ it "Servant.API.QueryParam" $ withServer $ \ host -> do

66+ runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice

67+ Left result <- runEitherT (getQueryParam (Just "bob") host)

68+ result `shouldContain` "bob not found"

69+

70+ context "client correctly handles error status codes" $ do

71+ let test :: WrappedApi -> Spec

72+ test (WrappedApi api) =

73+ it (show (typeOf api)) $

74+ withWaiDaemon (return (serve api (left (500, "error message")))) $

75+ \ (mkHost "localhost" -> host) -> do

76+ let getResponse :: URIAuth -> EitherT String IO ()

77+ getResponse = client api

78+ Left result <- runEitherT (getResponse host)

79+ result `shouldContain` "error message"

80+ mapM_ test $

81+ (WrappedApi (Proxy :: Proxy Delete)) :

82+ (WrappedApi (Proxy :: Proxy (Get ()))) :

83+ (WrappedApi (Proxy :: Proxy (Post ()))) :

84+ (WrappedApi (Proxy :: Proxy (Put ()))) :

85+ []

86+

87+data WrappedApi where

88+ WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,

89+ HasClient api, Client api ~ (URIAuth -> EitherT String IO ()),

90+ Typeable api) =>

91+ Proxy api -> WrappedApi

92+

56

93

57-- * utils

94-- * utils

58

95