eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #60 from codedmart/fix-baseurl

Browse source 
make BaseUrl an argument to 'client' instead of each function produced by 'client'
This commit is contained in:
Julian Arni 2015-05-09 02:28:31 +02:00
commit fc517a2f85
4 changed files with 287 additions and 253 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

215
servant-client/src/Servant/Client.hs
View file

@ -52,16 +52,17 @@ import Servant.Common.Req
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book] -- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book -- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi -- > (getAllBooks :<|> postNewBook) = client myApi
client :: HasClient layout => Proxy layout -> Client layout client :: HasClient layout => Proxy layout -> BaseUrl -> Client layout
client p = clientWithRoute p defReq client p baseurl = clientWithRoute p defReq baseurl
-- | This class lets us define how each API combinator -- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly -- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'. -- an internal class, you can just use 'client'.
class HasClient layout where class HasClient layout where
type Client layout :: * type Client layout :: *
clientWithRoute :: Proxy layout -> Req -> Client layout clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Client layout
{-type Client layout = Client layout-}
-- | A client querying function for @a ':<|>' b@ will actually hand you -- | A client querying function for @a ':<|>' b@ will actually hand you
-- one function for querying @a@ and another one for querying @b@, -- one function for querying @a@ and another one for querying @b@,
@ -78,9 +79,9 @@ class HasClient layout where
-- > (getAllBooks :<|> postNewBook) = client myApi -- > (getAllBooks :<|> postNewBook) = client myApi
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where 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 req baseurl =
clientWithRoute (Proxy :: Proxy a) req :<|> clientWithRoute (Proxy :: Proxy a) req baseurl :<|>
clientWithRoute (Proxy :: Proxy b) req clientWithRoute (Proxy :: Proxy b) req baseurl
-- | If you use a 'Capture' in one of your endpoints in your API, -- | If you use a 'Capture' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
@ -107,9 +108,10 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
type Client (Capture capture a :> sublayout) = type Client (Capture capture a :> sublayout) =
a -> Client sublayout a -> Client sublayout
clientWithRoute Proxy req val = clientWithRoute Proxy req baseurl val =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout)
appendToPath p req (appendToPath p req)
baseurl
where p = unpack (toText val) where p = unpack (toText val)
@ -122,9 +124,9 @@ instance
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where
type Client (Delete (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a type Client (Delete (ct ': cts) a) = EitherT ServantError IO a
clientWithRoute Proxy req host = clientWithRoute Proxy req baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] host snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
-- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -133,9 +135,9 @@ instance
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
HasClient (Delete (ct ': cts) ()) where HasClient (Delete (ct ': cts) ()) where
type Client (Delete (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client (Delete (ct ': cts) ()) = EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req baseurl =
void $ performRequestNoBody H.methodDelete req [204] host void $ performRequestNoBody H.methodDelete req [204] baseurl
-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -145,14 +147,13 @@ instance
#endif #endif
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Delete (ct ': cts) (Headers ls a)) where ) => HasClient (Delete (ct ': cts) (Headers ls a)) where
type Client (Delete (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a) type Client (Delete (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] host (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
-- | If you have a 'Get' endpoint in your API, the client -- | If you have a 'Get' endpoint in your API, the client
-- side querying function that is created when calling 'client' -- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host -- will just require an argument that specifies the scheme, host
@ -162,9 +163,9 @@ instance
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where (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) = EitherT ServantError IO result
clientWithRoute Proxy req host = clientWithRoute Proxy req baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl
-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
-- HTTP status. -- HTTP status.
@ -173,9 +174,9 @@ instance
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
HasClient (Get (ct ': cts) ()) where HasClient (Get (ct ': cts) ()) where
type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client (Get (ct ': cts) ()) = EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req baseurl =
performRequestNoBody H.methodGet req [204] host performRequestNoBody H.methodGet req [204] baseurl
-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -185,9 +186,9 @@ instance
#endif #endif
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Get (ct ': cts) (Headers ls a)) where ) => HasClient (Get (ct ': cts) (Headers ls a)) where
type Client (Get (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a) type Client (Get (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] host (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -223,9 +224,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
type Client (Header sym a :> sublayout) = type Client (Header sym a :> sublayout) =
Maybe a -> Client sublayout Maybe a -> Client sublayout
clientWithRoute Proxy req mval = clientWithRoute Proxy req baseurl mval =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout)
maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval (maybe req
(\value -> Servant.Common.Req.addHeader hname value req)
mval
)
baseurl
where hname = symbolVal (Proxy :: Proxy sym) where hname = symbolVal (Proxy :: Proxy sym)
@ -238,10 +243,9 @@ instance
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where (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) = EitherT ServantError IO a
clientWithRoute Proxy req baseurl =
clientWithRoute Proxy req uri = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] baseurl
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -250,9 +254,9 @@ instance
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
HasClient (Post (ct ': cts) ()) where HasClient (Post (ct ': cts) ()) where
type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client (Post (ct ': cts) ()) = EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req baseurl =
void $ performRequestNoBody H.methodPost req [204] host void $ performRequestNoBody H.methodPost req [204] baseurl
-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -262,9 +266,9 @@ instance
#endif #endif
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Post (ct ': cts) (Headers ls a)) where ) => HasClient (Post (ct ': cts) (Headers ls a)) where
type Client (Post (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a) type Client (Post (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] host (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -278,10 +282,9 @@ instance
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where (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) = EitherT ServantError IO a
clientWithRoute Proxy req baseurl =
clientWithRoute Proxy req host = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -290,9 +293,9 @@ instance
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
HasClient (Put (ct ': cts) ()) where HasClient (Put (ct ': cts) ()) where
type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client (Put (ct ': cts) ()) = EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req baseurl =
void $ performRequestNoBody H.methodPut req [204] host void $ performRequestNoBody H.methodPut req [204] baseurl
-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -302,9 +305,9 @@ instance
#endif #endif
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Put (ct ': cts) (Headers ls a)) where ) => HasClient (Put (ct ': cts) (Headers ls a)) where
type Client (Put (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a) type Client (Put (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] host (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -318,10 +321,9 @@ instance
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where (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) = EitherT ServantError IO a
clientWithRoute Proxy req baseurl =
clientWithRoute Proxy req host = snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -330,9 +332,9 @@ instance
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
HasClient (Patch (ct ': cts) ()) where HasClient (Patch (ct ': cts) ()) where
type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client (Patch (ct ': cts) ()) = EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req baseurl =
void $ performRequestNoBody H.methodPatch req [204] host void $ performRequestNoBody H.methodPatch req [204] baseurl
-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -342,9 +344,9 @@ instance
#endif #endif
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Patch (ct ': cts) (Headers ls a)) where ) => HasClient (Patch (ct ': cts) (Headers ls a)) where
type Client (Patch (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a) type Client (Patch (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] host (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -381,9 +383,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
Maybe a -> Client sublayout Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string -- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam = clientWithRoute Proxy req baseurl mparam =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout)
maybe req (flip (appendToQueryString pname) req . Just) mparamText (maybe req
(flip (appendToQueryString pname) req . Just)
mparamText
)
baseurl
where pname = cs pname' where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym) pname' = symbolVal (Proxy :: Proxy sym)
@ -422,9 +428,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
type Client (QueryParams sym a :> sublayout) = type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout [a] -> Client sublayout
clientWithRoute Proxy req paramlist = clientWithRoute Proxy req baseurl paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout)
foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req
paramlist'
)
baseurl
where pname = cs pname' where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym) pname' = symbolVal (Proxy :: Proxy sym)
@ -457,11 +467,13 @@ instance (KnownSymbol sym, HasClient sublayout)
type Client (QueryFlag sym :> sublayout) = type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout Bool -> Client sublayout
clientWithRoute Proxy req flag = clientWithRoute Proxy req baseurl flag =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout)
if flag (if flag
then appendToQueryString paramname Nothing req then appendToQueryString paramname Nothing req
else req else req
)
baseurl
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
@ -497,9 +509,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
Maybe a -> Client sublayout Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string -- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam = clientWithRoute Proxy req baseurl mparam =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout)
maybe req (flip (appendToMatrixParams pname . Just) req) mparamText (maybe req
(flip (appendToMatrixParams pname . Just) req)
mparamText
)
baseurl
where pname = symbolVal (Proxy :: Proxy sym) where pname = symbolVal (Proxy :: Proxy sym)
mparamText = fmap (cs . toText) mparam mparamText = fmap (cs . toText) mparam
@ -537,9 +553,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
type Client (MatrixParams sym a :> sublayout) = type Client (MatrixParams sym a :> sublayout) =
[a] -> Client sublayout [a] -> Client sublayout
clientWithRoute Proxy req paramlist = clientWithRoute Proxy req baseurl paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout)
foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value) req paramlist' (foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value)
req
paramlist'
)
baseurl
where pname = cs pname' where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym) pname' = symbolVal (Proxy :: Proxy sym)
@ -572,22 +592,24 @@ instance (KnownSymbol sym, HasClient sublayout)
type Client (MatrixFlag sym :> sublayout) = type Client (MatrixFlag sym :> sublayout) =
Bool -> Client sublayout Bool -> Client sublayout
clientWithRoute Proxy req flag = clientWithRoute Proxy req baseurl flag =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout)
if flag (if flag
then appendToMatrixParams paramname Nothing req then appendToMatrixParams paramname Nothing req
else req else req
)
baseurl
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | Pick a 'Method' and specify where the server you want to query is. You get -- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`. -- back the full `Response`.
instance HasClient Raw where instance HasClient Raw where
type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) type Client Raw = H.Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> Client Raw clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw
clientWithRoute Proxy req httpMethod host = do clientWithRoute Proxy req baseurl httpMethod = do
performRequest httpMethod req (const True) host performRequest httpMethod req (const True) baseurl
-- | If you use a 'ReqBody' in one of your endpoints in your API, -- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
@ -613,18 +635,23 @@ instance (MimeRender ct a, HasClient sublayout)
type Client (ReqBody (ct ': cts) a :> sublayout) = type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout a -> Client sublayout
clientWithRoute Proxy req body = clientWithRoute Proxy req baseurl body =
clientWithRoute (Proxy :: Proxy sublayout) $ do clientWithRoute (Proxy :: Proxy sublayout)
let ctProxy = Proxy :: Proxy ct (let ctProxy = Proxy :: Proxy ct
setRQBody (mimeRender ctProxy body) (contentType ctProxy) req in setRQBody (mimeRender ctProxy body)
(contentType ctProxy)
req
)
baseurl
-- | Make the querying function append @path@ to the request path. -- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where 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 req baseurl =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout)
appendToPath p req (appendToPath p req)
baseurl
where p = symbolVal (Proxy :: Proxy path) where p = symbolVal (Proxy :: Proxy path)

298
servant-client/test/Servant/ClientSpec.hs
View file

@ -9,6 +9,7 @@
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fcontext-stack=100 #-} {-# OPTIONS_GHC -fcontext-stack=100 #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.ClientSpec where module Servant.ClientSpec where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
@ -80,7 +81,6 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
type Api = type Api =
"get" :> Get '[JSON] Person "get" :> Get '[JSON] Person
:<|> "delete" :> Delete '[JSON] () :<|> "delete" :> Delete '[JSON] ()
:<|> "deleteString" :> Delete '[JSON] String
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
@ -105,7 +105,6 @@ server :: Application
server = serve api ( server = serve api (
return alice return alice
:<|> return () :<|> return ()
:<|> return "ok"
:<|> (\ name -> return $ Person name 0) :<|> (\ name -> return $ Person name 0)
:<|> return :<|> return
:<|> (\ name -> case name of :<|> (\ name -> case name of
@ -129,42 +128,6 @@ server = serve api (
withServer :: (BaseUrl -> IO a) -> IO a withServer :: (BaseUrl -> IO a) -> IO a
withServer action = withWaiDaemon (return server) action withServer action = withWaiDaemon (return server) action
getGet :: BaseUrl -> EitherT ServantError IO Person
getDelete :: BaseUrl -> EitherT ServantError IO ()
getDeleteString :: BaseUrl -> EitherT ServantError IO String
getCapture :: String -> BaseUrl -> EitherT ServantError IO Person
getBody :: Person -> BaseUrl -> EitherT ServantError IO Person
getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
getQueryParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
MediaType, [HTTP.Header], C.Response ByteString)
getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString,
MediaType, [HTTP.Header], C.Response ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
-> BaseUrl
-> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)
( getGet
:<|> getDelete
:<|> getDeleteString
:<|> getCapture
:<|> getBody
:<|> getQueryParam
:<|> getQueryParams
:<|> getQueryFlag
:<|> getMatrixParam
:<|> getMatrixParams
:<|> getMatrixFlag
:<|> getRawSuccess
:<|> getRawFailure
:<|> getMultiple
:<|> getRespHeaders)
= client api
type FailApi = type FailApi =
"get" :> Raw "get" :> Raw
:<|> "capture" :> Capture "name" String :> Raw :<|> "capture" :> Capture "name" String :> Raw
@ -182,141 +145,182 @@ failServer = serve failApi (
withFailServer :: (BaseUrl -> IO a) -> IO a withFailServer :: (BaseUrl -> IO a) -> IO a
withFailServer action = withWaiDaemon (return failServer) action withFailServer action = withWaiDaemon (return failServer) action
spec :: Spec spec :: IO ()
spec = do spec = withServer $ \ baseUrl -> do
it "Servant.API.Get" $ withServer $ \ host -> do let getGet :: EitherT ServantError IO Person
(Arrow.left show <$> runEitherT (getGet host)) `shouldReturn` Right alice getDelete :: EitherT ServantError IO ()
getCapture :: String -> EitherT ServantError IO Person
getBody :: Person -> EitherT ServantError IO Person
getQueryParam :: Maybe String -> EitherT ServantError IO Person
getQueryParams :: [String] -> EitherT ServantError IO [Person]
getQueryFlag :: Bool -> EitherT ServantError IO Bool
getMatrixParam :: Maybe String -> EitherT ServantError IO Person
getMatrixParams :: [String] -> EitherT ServantError IO [Person]
getMatrixFlag :: Bool -> EitherT ServantError IO Bool
getRawSuccess :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)
getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool)
( getGet
:<|> getDelete
:<|> getCapture
:<|> getBody
:<|> getQueryParam
:<|> getQueryParams
:<|> getQueryFlag
:<|> getMatrixParam
:<|> getMatrixParams
:<|> getMatrixFlag
:<|> getRawSuccess
:<|> getRawFailure
:<|> getMultiple
:<|> getRespHeaders)
= client api baseUrl
context "Servant.API.Delete" $ do hspec $ do
it "return no body" $ withServer $ \ host -> do it "Servant.API.Get" $ do
(Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right () (Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice
it "return body" $ withServer $ \ host -> do it "Servant.API.Delete" $ do
(Arrow.left show <$> runEitherT (getDeleteString host)) `shouldReturn` Right "ok" (Arrow.left show <$> runEitherT getDelete) `shouldReturn` Right ()
it "Servant.API.Capture" $ withServer $ \ host -> do it "Servant.API.Capture" $ do
(Arrow.left show <$> runEitherT (getCapture "Paula" host)) `shouldReturn` Right (Person "Paula" 0) (Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.ReqBody" $ withServer $ \ host -> do it "Servant.API.ReqBody" $ do
let p = Person "Clara" 42 let p = Person "Clara" 42
(Arrow.left show <$> runEitherT (getBody p host)) `shouldReturn` Right p (Arrow.left show <$> runEitherT (getBody p)) `shouldReturn` Right p
it "Servant.API.QueryParam" $ withServer $ \ host -> do it "Servant.API.QueryParam" $ do
Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice Arrow.left show <$> runEitherT (getQueryParam (Just "alice")) `shouldReturn` Right alice
Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob") host) Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob"))
responseStatus `shouldBe` Status 400 "bob not found" responseStatus `shouldBe` Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do it "Servant.API.QueryParam.QueryParams" $ do
(Arrow.left show <$> runEitherT (getQueryParams [] host)) `shouldReturn` Right [] (Arrow.left show <$> runEitherT (getQueryParams [])) `shouldReturn` Right []
(Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"] host)) (Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"]))
`shouldReturn` Right [Person "alice" 0, Person "bob" 1] `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $ context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> forM_ [False, True] $ \ flag ->
it (show flag) $ withServer $ \ host -> do it (show flag) $ do
(Arrow.left show <$> runEitherT (getQueryFlag flag host)) `shouldReturn` Right flag (Arrow.left show <$> runEitherT (getQueryFlag flag)) `shouldReturn` Right flag
it "Servant.API.MatrixParam" $ withServer $ \ host -> do it "Servant.API.MatrixParam" $ do
Arrow.left show <$> runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice Arrow.left show <$> runEitherT (getMatrixParam (Just "alice")) `shouldReturn` Right alice
Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob") host) Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob"))
responseStatus `shouldBe` Status 400 "bob not found" responseStatus `shouldBe` Status 400 "bob not found"
it "Servant.API.MatrixParam.MatrixParams" $ withServer $ \ host -> do it "Servant.API.MatrixParam.MatrixParams" $ do
Arrow.left show <$> runEitherT (getMatrixParams [] host) `shouldReturn` Right [] Arrow.left show <$> runEitherT (getMatrixParams []) `shouldReturn` Right []
Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"] host) Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"])
`shouldReturn` Right [Person "alice" 0, Person "bob" 1] `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.MatrixParam.MatrixFlag" $ context "Servant.API.MatrixParam.MatrixFlag" $
forM_ [False, True] $ \ flag -> forM_ [False, True] $ \ flag ->
it (show flag) $ withServer $ \ host -> do it (show flag) $ do
Arrow.left show <$> runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag Arrow.left show <$> runEitherT (getMatrixFlag flag) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ withServer $ \ host -> do it "Servant.API.Raw on success" $ do
res <- runEitherT (getRawSuccess methodGet host) res <- runEitherT (getRawSuccess methodGet)
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do Right (code, body, ct, _, response) -> do
(code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
C.responseBody response `shouldBe` body C.responseBody response `shouldBe` body
C.responseStatus response `shouldBe` ok200 C.responseStatus response `shouldBe` ok200
it "Servant.API.Raw on failure" $ withServer $ \ host -> do it "Servant.API.Raw on failure" $ do
res <- runEitherT (getRawFailure methodGet host) res <- runEitherT (getRawFailure methodGet)
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do Right (code, body, ct, _, response) -> do
(code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream") (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")
C.responseBody response `shouldBe` body C.responseBody response `shouldBe` body
C.responseStatus response `shouldBe` badRequest400 C.responseStatus response `shouldBe` badRequest400
it "Returns headers appropriately" $ withServer $ \ host -> do it "Returns headers appropriately" $ withServer $ \ _ -> do
res <- runEitherT (getRespHeaders host) res <- runEitherT getRespHeaders
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
modifyMaxSuccess (const 20) $ do modifyMaxSuccess (const 20) $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do ioProperty $ do
withServer $ \ host -> do result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body)
result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body host)
return $ return $
result === Right (cap, num, flag, body) result === Right (cap, num, flag, body)
context "client correctly handles error status codes" $ do context "client correctly handles error status codes" $ do
let test :: (WrappedApi, String) -> Spec let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) = test (WrappedApi api, desc) =
it desc $ it desc $
withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $ withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $
\ host -> do \ host -> do
let getResponse :: BaseUrl -> EitherT ServantError IO () let getResponse :: EitherT ServantError IO ()
getResponse = client api getResponse = client api host
Left FailureResponse{..} <- runEitherT (getResponse host) Left FailureResponse{..} <- runEitherT getResponse
responseStatus `shouldBe` (Status 500 "error message") responseStatus `shouldBe` (Status 500 "error message")
mapM_ test $ mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
(WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") : (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
(WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") : (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
[] []
context "client returns errors appropriately" $ do failSpec :: IO ()
it "reports FailureResponse" $ withFailServer $ \ host -> do failSpec = withFailServer $ \ baseUrl -> do
Left res <- runEitherT (getDelete host) let getGet :: EitherT ServantError IO Person
case res of getDelete :: EitherT ServantError IO ()
FailureResponse (Status 404 "Not Found") _ _ -> return () getCapture :: String -> EitherT ServantError IO Person
_ -> fail $ "expected 404 response, but got " <> show res getBody :: Person -> EitherT ServantError IO Person
( getGet
:<|> getDelete
:<|> getCapture
:<|> getBody
:<|> _ )
= client api baseUrl
getGetWrongHost :: EitherT ServantError IO Person
(getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872)
it "reports DecodeFailure" $ withFailServer $ \ host -> do hspec $ do
Left res <- runEitherT (getCapture "foo" host) context "client returns errors appropriately" $ do
case res of it "reports FailureResponse" $ do
DecodeFailure _ ("application/json") _ -> return () Left res <- runEitherT getDelete
_ -> fail $ "expected DecodeFailure, but got " <> show res case res of
FailureResponse (Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res
it "reports ConnectionError" $ do it "reports DecodeFailure" $ do
Right host <- return $ parseBaseUrl "127.0.0.1:987654" Left res <- runEitherT (getCapture "foo")
Left res <- runEitherT (getGet host) case res of
case res of DecodeFailure _ ("application/json") _ -> return ()
ConnectionError (C.FailedConnectionException2 "127.0.0.1" 987654 False _) -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res
_ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ withFailServer $ \ host -> do it "reports ConnectionError" $ do
Left res <- runEitherT (getGet host) Left res <- runEitherT getGetWrongHost
case res of case res of
UnsupportedContentType ("application/octet-stream") _ -> return () ConnectionError (C.FailedConnectionException2 "127.0.0.1" 19872 False _) -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res _ -> fail $ "expected ConnectionError, but got " <> show res
it "reports InvalidContentTypeHeader" $ withFailServer $ \ host -> do it "reports UnsupportedContentType" $ do
Left res <- runEitherT (getBody alice host) Left res <- runEitherT getGet
case res of case res of
InvalidContentTypeHeader "fooooo" _ -> return () UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res _ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ do
Left res <- runEitherT (getBody alice)
case res of
InvalidContentTypeHeader "fooooo" _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where data WrappedApi where
WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a, WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a,
HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) => HasClient api, Client api ~ EitherT ServantError IO ()) =>
Proxy api -> WrappedApi Proxy api -> WrappedApi

8
servant-client/test/Spec.hs
View file

@ -1 +1,7 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-} import Servant.ClientSpec (spec, failSpec)
main :: IO ()
main = do
spec
failSpec

19
servant-examples/hackage/hackage.hs
View file

@ -54,29 +54,26 @@ instance FromJSON Package
hackageAPI :: Proxy HackageAPI hackageAPI :: Proxy HackageAPI
hackageAPI = Proxy hackageAPI = Proxy
getUsers :: BaseUrl -> EitherT ServantError IO [UserSummary] getUsers :: EitherT ServantError IO [UserSummary]
getUser :: Username -> BaseUrl -> EitherT ServantError IO UserDetailed getUser :: Username -> EitherT ServantError IO UserDetailed
getPackages :: BaseUrl -> EitherT ServantError IO [Package] getPackages :: EitherT ServantError IO [Package]
getUsers :<|> getUser :<|> getPackages = client hackageAPI getUsers :<|> getUser :<|> getPackages = client hackageAPI $ BaseUrl Http "hackage.haskell.org" 80
run :: (BaseUrl -> r) -> r
run f = f (BaseUrl Http "hackage.haskell.org" 80)
main :: IO () main :: IO ()
main = print =<< uselessNumbers main = print =<< uselessNumbers
uselessNumbers :: IO (Either ServantError ()) uselessNumbers :: IO (Either ServantError ())
uselessNumbers = runEitherT $ do uselessNumbers = runEitherT $ do
users <- run getUsers users <- getUsers
liftIO . putStrLn $ show (length users) ++ " users" liftIO . putStrLn $ show (length users) ++ " users"
user <- liftIO $ do user <- liftIO $ do
putStrLn "Enter a valid hackage username" putStrLn "Enter a valid hackage username"
T.getLine T.getLine
userDetailed <- run (getUser user) userDetailed <- (getUser user)
liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages" liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages"
packages <- run getPackages packages <- getPackages
let monadPackages = filter (isMonadPackage . packageName) packages let monadPackages = filter (isMonadPackage . packageName) packages
liftIO . putStrLn $ show (length monadPackages) ++ " monad packages" liftIO . putStrLn $ show (length monadPackages) ++ " monad packages"