Merge pull request #25 from haskell-servant/canonical-types-rebased
Canonical types rebased
This commit is contained in:
Alp Mestanogullari
commit
0173087166
4 changed files with 78 additions and 73 deletions
|
|
@ -7,6 +7,7 @@
|
|||
* Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
|
||||
* Support for PATCH
|
||||
* Make () instances expect No Content status code, and not try to decode body.
|
||||
* `Canonicalize` API types before generating client functions for them
|
||||
|
||||
0.2.2
|
||||
-----
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
|
|
@ -12,6 +13,7 @@
|
|||
module Servant.Client
|
||||
( client
|
||||
, HasClient(..)
|
||||
, Client
|
||||
, ServantError(..)
|
||||
, module Servant.Common.BaseUrl
|
||||
) where
|
||||
|
|
@ -45,15 +47,17 @@ import Servant.Common.Req
|
|||
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
|
||||
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
client :: HasClient layout => Proxy layout -> Client layout
|
||||
client p = clientWithRoute p defReq
|
||||
client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout
|
||||
client p = clientWithRoute (canonicalize p) defReq
|
||||
|
||||
-- | This class lets us define how each API combinator
|
||||
-- influences the creation of an HTTP request. It's mostly
|
||||
-- an internal class, you can just use 'client'.
|
||||
class HasClient layout where
|
||||
type Client layout :: *
|
||||
clientWithRoute :: Proxy layout -> Req -> Client layout
|
||||
type Client' layout :: *
|
||||
clientWithRoute :: Proxy layout -> Req -> Client' layout
|
||||
|
||||
type Client layout = Client' (Canonicalize layout)
|
||||
|
||||
-- | A client querying function for @a ':<|>' b@ will actually hand you
|
||||
-- one function for querying @a@ and another one for querying @b@,
|
||||
|
|
@ -69,7 +73,7 @@ class HasClient layout where
|
|||
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
|
||||
type Client (a :<|> b) = Client a :<|> Client b
|
||||
type Client' (a :<|> b) = Client' a :<|> Client' b
|
||||
clientWithRoute Proxy req =
|
||||
clientWithRoute (Proxy :: Proxy a) req :<|>
|
||||
clientWithRoute (Proxy :: Proxy b) req
|
||||
|
|
@ -96,8 +100,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
|
|||
instance (KnownSymbol capture, ToText a, HasClient sublayout)
|
||||
=> HasClient (Capture capture a :> sublayout) where
|
||||
|
||||
type Client (Capture capture a :> sublayout) =
|
||||
a -> Client sublayout
|
||||
type Client' (Capture capture a :> sublayout) =
|
||||
a -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req val =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
|
|
@ -110,7 +114,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
|
|||
-- will just require an argument that specifies the scheme, host
|
||||
-- and port to send the request to.
|
||||
instance HasClient Delete where
|
||||
type Client Delete = BaseUrl -> EitherT ServantError IO ()
|
||||
type Client' Delete = BaseUrl -> EitherT ServantError IO ()
|
||||
|
||||
clientWithRoute Proxy req host =
|
||||
void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
|
||||
|
|
@ -120,14 +124,14 @@ instance HasClient Delete where
|
|||
-- will just require an argument that specifies the scheme, host
|
||||
-- and port to send the request to.
|
||||
instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
|
||||
type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
|
||||
type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
|
||||
clientWithRoute Proxy req host =
|
||||
performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
|
||||
|
||||
-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
|
||||
-- HTTP header.
|
||||
instance HasClient (Get (ct ': cts) ()) where
|
||||
type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
clientWithRoute Proxy req host =
|
||||
performRequestNoBody H.methodGet req [204] host
|
||||
|
||||
|
|
@ -159,12 +163,12 @@ instance HasClient (Get (ct ': cts) ()) where
|
|||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||
=> HasClient (Header sym a :> sublayout) where
|
||||
|
||||
type Client (Header sym a :> sublayout) =
|
||||
Maybe a -> Client sublayout
|
||||
type Client' (Header sym a :> sublayout) =
|
||||
Maybe a -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req mval =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
maybe req (\value -> addHeader hname value req) mval
|
||||
maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval
|
||||
|
||||
where hname = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
|
|
@ -173,7 +177,7 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
|||
-- will just require an argument that specifies the scheme, host
|
||||
-- and port to send the request to.
|
||||
instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
|
||||
type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
|
||||
type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
|
||||
|
||||
clientWithRoute Proxy req uri =
|
||||
performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
|
||||
|
|
@ -181,7 +185,7 @@ instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
|
|||
-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
|
||||
-- HTTP header.
|
||||
instance HasClient (Post (ct ': cts) ()) where
|
||||
type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
clientWithRoute Proxy req host =
|
||||
void $ performRequestNoBody H.methodPost req [204] host
|
||||
|
||||
|
|
@ -190,7 +194,7 @@ instance HasClient (Post (ct ': cts) ()) where
|
|||
-- will just require an argument that specifies the scheme, host
|
||||
-- and port to send the request to.
|
||||
instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
|
||||
type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
|
||||
type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
|
||||
|
||||
clientWithRoute Proxy req host =
|
||||
performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
|
||||
|
|
@ -198,7 +202,7 @@ instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
|
|||
-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
|
||||
-- HTTP header.
|
||||
instance HasClient (Put (ct ': cts) ()) where
|
||||
type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
clientWithRoute Proxy req host =
|
||||
void $ performRequestNoBody H.methodPut req [204] host
|
||||
|
||||
|
|
@ -207,7 +211,7 @@ instance HasClient (Put (ct ': cts) ()) where
|
|||
-- will just require an argument that specifies the scheme, host
|
||||
-- and port to send the request to.
|
||||
instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
|
||||
type Client (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
|
||||
type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
|
||||
|
||||
clientWithRoute Proxy req host =
|
||||
performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
|
||||
|
|
@ -215,7 +219,7 @@ instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
|
|||
-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
|
||||
-- HTTP header.
|
||||
instance HasClient (Patch (ct ': cts) ()) where
|
||||
type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
|
||||
clientWithRoute Proxy req host =
|
||||
void $ performRequestNoBody H.methodPatch req [204] host
|
||||
|
||||
|
|
@ -247,8 +251,8 @@ instance HasClient (Patch (ct ': cts) ()) where
|
|||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||
=> HasClient (QueryParam sym a :> sublayout) where
|
||||
|
||||
type Client (QueryParam sym a :> sublayout) =
|
||||
Maybe a -> Client sublayout
|
||||
type Client' (QueryParam sym a :> sublayout) =
|
||||
Maybe a -> Client' sublayout
|
||||
|
||||
-- if mparam = Nothing, we don't add it to the query string
|
||||
clientWithRoute Proxy req mparam =
|
||||
|
|
@ -289,8 +293,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
|||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||
=> HasClient (QueryParams sym a :> sublayout) where
|
||||
|
||||
type Client (QueryParams sym a :> sublayout) =
|
||||
[a] -> Client sublayout
|
||||
type Client' (QueryParams sym a :> sublayout) =
|
||||
[a] -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req paramlist =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
|
|
@ -324,8 +328,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
|||
instance (KnownSymbol sym, HasClient sublayout)
|
||||
=> HasClient (QueryFlag sym :> sublayout) where
|
||||
|
||||
type Client (QueryFlag sym :> sublayout) =
|
||||
Bool -> Client sublayout
|
||||
type Client' (QueryFlag sym :> sublayout) =
|
||||
Bool -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req flag =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
|
|
@ -363,8 +367,8 @@ instance (KnownSymbol sym, HasClient sublayout)
|
|||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||
=> HasClient (MatrixParam sym a :> sublayout) where
|
||||
|
||||
type Client (MatrixParam sym a :> sublayout) =
|
||||
Maybe a -> Client sublayout
|
||||
type Client' (MatrixParam sym a :> sublayout) =
|
||||
Maybe a -> Client' sublayout
|
||||
|
||||
-- if mparam = Nothing, we don't add it to the query string
|
||||
clientWithRoute Proxy req mparam =
|
||||
|
|
@ -404,8 +408,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
|||
instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||
=> HasClient (MatrixParams sym a :> sublayout) where
|
||||
|
||||
type Client (MatrixParams sym a :> sublayout) =
|
||||
[a] -> Client sublayout
|
||||
type Client' (MatrixParams sym a :> sublayout) =
|
||||
[a] -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req paramlist =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
|
|
@ -439,8 +443,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
|||
instance (KnownSymbol sym, HasClient sublayout)
|
||||
=> HasClient (MatrixFlag sym :> sublayout) where
|
||||
|
||||
type Client (MatrixFlag sym :> sublayout) =
|
||||
Bool -> Client sublayout
|
||||
type Client' (MatrixFlag sym :> sublayout) =
|
||||
Bool -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req flag =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
|
|
@ -453,9 +457,9 @@ instance (KnownSymbol sym, HasClient sublayout)
|
|||
-- | Pick a 'Method' and specify where the server you want to query is. You get
|
||||
-- back the full `Response`.
|
||||
instance HasClient Raw where
|
||||
type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
|
||||
type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
|
||||
|
||||
clientWithRoute :: Proxy Raw -> Req -> Client Raw
|
||||
clientWithRoute :: Proxy Raw -> Req -> Client' Raw
|
||||
clientWithRoute Proxy req httpMethod host = do
|
||||
performRequest httpMethod req (const True) host
|
||||
|
||||
|
|
@ -480,17 +484,17 @@ instance HasClient Raw where
|
|||
instance (MimeRender ct a, HasClient sublayout)
|
||||
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where
|
||||
|
||||
type Client (ReqBody (ct ': cts) a :> sublayout) =
|
||||
a -> Client sublayout
|
||||
type Client' (ReqBody (ct ': cts) a :> sublayout) =
|
||||
a -> Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req body =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $ do
|
||||
let ctProxy = Proxy :: Proxy ct
|
||||
setRQBody (toByteString ctProxy body) (contentType ctProxy) req
|
||||
setRQBody (mimeRender ctProxy body) (contentType ctProxy) req
|
||||
|
||||
-- | Make the querying function append @path@ to the request path.
|
||||
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
|
||||
type Client (path :> sublayout) = Client sublayout
|
||||
type Client' (path :> sublayout) = Client' sublayout
|
||||
|
||||
clientWithRoute Proxy req =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||
|
|
|
|||
|
|
@ -172,7 +172,7 @@ performRequestCT ct reqMethod req wantedStatus reqHost = do
|
|||
either
|
||||
(left . (\s -> DecodeFailure s respCT respBody))
|
||||
return
|
||||
(fromByteString ct respBody)
|
||||
(mimeUnrender ct respBody)
|
||||
|
||||
performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
|
||||
performRequestNoBody reqMethod req wantedStatus reqHost = do
|
||||
|
|
|
|||
|
|
@ -1,42 +1,42 @@
|
|||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fcontext-stack=25 #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.ClientSpec where
|
||||
|
||||
import Control.Applicative
|
||||
import qualified Control.Arrow as Arrow
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.Aeson
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Char
|
||||
import Data.Foldable (forM_)
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import qualified Network.HTTP.Client as C
|
||||
import Network.HTTP.Media
|
||||
import Network.HTTP.Types
|
||||
import Network.Socket
|
||||
import Network.Wai hiding (Response)
|
||||
import Network.Wai.Handler.Warp
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit
|
||||
import Test.QuickCheck
|
||||
import Control.Applicative
|
||||
import qualified Control.Arrow as Arrow
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad.Trans.Either
|
||||
import Data.Aeson
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Char
|
||||
import Data.Foldable (forM_)
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import qualified Network.HTTP.Client as C
|
||||
import Network.HTTP.Media
|
||||
import Network.HTTP.Types
|
||||
import Network.Socket
|
||||
import Network.Wai hiding (Response)
|
||||
import Network.Wai.Handler.Warp
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit
|
||||
import Test.QuickCheck
|
||||
|
||||
import Servant.API
|
||||
import Servant.Client
|
||||
import Servant.Server
|
||||
import Servant.API
|
||||
import Servant.Client
|
||||
import Servant.Server
|
||||
|
||||
-- * test data types
|
||||
|
||||
|
|
@ -289,8 +289,8 @@ spec = do
|
|||
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
|
||||
|
||||
data WrappedApi where
|
||||
WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
|
||||
HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
|
||||
WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a,
|
||||
HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
|
||||
Proxy api -> WrappedApi
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue