Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Consolidate verbs #276

Merged
merged 12 commits into from Jan 8, 2016
Merged

Consolidate verbs #276

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
12 commits
Select commit Hold shift + click to select a range
cda8bcf
Simplify verb combinators.
jkarni Nov 27, 2015
190c75a
Add descriptive type synonyms for success responses.
jkarni Dec 27, 2015
c6071bf
Don't override status code on empty body.
jkarni Dec 27, 2015
20ae7dc
Update CHANGELOG for Verbs change.
jkarni Dec 27, 2015
9b2d7a7
Remove unnecesary () AllMimeRender instance.
jkarni Dec 27, 2015
5909a6d
Fix rebase issues.
jkarni Jan 6, 2016
208bcf5
Use Verb for servant-docs
jkarni Jan 6, 2016
bd77b4a
Verb for -mock, -js and -foreign.
jkarni Jan 6, 2016
574e9c4
Export all Verb methods.
jkarni Jan 7, 2016
783a849
Make NoContent still take an arg.
jkarni Jan 7, 2016
f1b6603
Review fixes
jkarni Jan 8, 2016
f9c6137
Refactor NoContent logic.
jkarni Jan 8, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
169 changes: 44 additions & 125 deletions servant-client/src/Servant/Client.hs
View file
Open in desktop
Expand Up @@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
Expand All @@ -23,7 +24,6 @@ module Servant.Client
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad
import Control.Monad.Trans.Except
import Data.ByteString.Lazy (ByteString)
import Data.List
Expand All @@ -44,7 +44,7 @@ import Servant.Common.Req
-- | 'client' allows you to produce operations to query an API from a client.
--
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
Expand Down Expand Up @@ -118,62 +118,48 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)

where p = unpack (toUrlPiece val)

-- | If you have a 'Delete' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance OVERLAPPABLE_
(MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
type Client (Delete cts' a) = ExceptT ServantError IO a
-- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager
snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager
where method = reflectMethod (Proxy :: Proxy method)

instance OVERLAPPING_
HasClient (Delete cts ()) where
type Client (Delete cts ()) = ExceptT ServantError IO ()
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodDelete req baseurl manager
performRequestNoBody method req baseurl manager >> return NoContent
where method = reflectMethod (Proxy :: Proxy method)

-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)
) => HasClient (Delete cts' (Headers ls a)) where
type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
-- Note [Non-Empty Content Types]
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where
type Client (Verb method status cts' (Headers ls a))
= ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager
let method = reflectMethod (Proxy :: Proxy method)
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}

-- | If you have a 'Get' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance OVERLAPPABLE_
(MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
type Client (Get (ct ': cts) result) = ExceptT ServantError IO result
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager

instance OVERLAPPING_
HasClient (Get (ct ': cts) ()) where
type Client (Get (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager =
performRequestNoBody H.methodGet req baseurl manager

-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Get (ct ': cts) (Headers ls a)) where
type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent))
= ExceptT ServantError IO (Headers ls NoContent)
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager
return $ Headers { getResponse = resp
let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req baseurl manager
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs
}


-- | If you use a 'Header' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'Header',
Expand Down Expand Up @@ -217,90 +203,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)

where hname = symbolVal (Proxy :: Proxy sym)

-- | If you have a 'Post' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance OVERLAPPABLE_
(MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
type Client (Post (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager

instance OVERLAPPING_
HasClient (Post (ct ': cts) ()) where
type Client (Post (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPost req baseurl manager

-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Post (ct ': cts) (Headers ls a)) where
type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}

-- | If you have a 'Put' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance OVERLAPPABLE_
(MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
type Client (Put (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager

instance OVERLAPPING_
HasClient (Put (ct ': cts) ()) where
type Client (Put (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPut req baseurl manager

-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Put (ct ': cts) (Headers ls a)) where
type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager= do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}

-- | If you have a 'Patch' endpoint in your API, the client
-- side querying function that is created when calling 'client'
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance OVERLAPPABLE_
(MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager

instance OVERLAPPING_
HasClient (Patch (ct ': cts) ()) where
type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPatch req baseurl manager

-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Patch (ct ': cts) (Headers ls a)) where
type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}

-- | If you use a 'QueryParam' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'QueryParam',
Expand Down Expand Up @@ -503,3 +405,20 @@ instance HasClient api => HasClient (IsSecure :> api) where

clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) req baseurl manager


{- Note [Non-Empty Content Types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Rather than have

instance (..., cts' ~ (ct ': cts)) => ... cts' ...

It may seem to make more sense to have:

instance (...) => ... (ct ': cts) ...

But this means that if another instance exists that does *not* require
non-empty lists, but is otherwise more specific, no instance will be overall
more specific. This in turn generally means adding yet another instance (one
for empty and one for non-empty lists).
-}
19 changes: 11 additions & 8 deletions servant-client/src/Servant/Common/Req.hs
View file
Open in desktop
Expand Up @@ -142,7 +142,7 @@ performRequest reqMethod req reqHost manager = do
Right response -> do
let status = Client.responseStatus response
body = Client.responseBody response
hrds = Client.responseHeaders response
hdrs = Client.responseHeaders response
status_code = statusCode status
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream"
Expand All @@ -151,23 +151,26 @@ performRequest reqMethod req reqHost manager = do
Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $
throwE $ FailureResponse status ct body
return (status_code, body, ct, hrds, response)
return (status_code, body, ct, hdrs, response)


performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)
Proxy ct -> Method -> Req -> BaseUrl -> Manager
-> ExceptT ServantError IO ([HTTP.Header], result)
performRequestCT ct reqMethod req reqHost manager = do
let acceptCT = contentType ct
(_status, respBody, respCT, hrds, _response) <-
(_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody
Right val -> return (hrds, val)
Right val -> return (hdrs, val)

performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ()
performRequestNoBody reqMethod req reqHost manager =
void $ performRequest reqMethod req reqHost manager
performRequestNoBody :: Method -> Req -> BaseUrl -> Manager
-> ExceptT ServantError IO [HTTP.Header]
performRequestNoBody reqMethod req reqHost manager = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager
return hdrs
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Before this change you couldn't return headers when returning ()?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Nope - this fixes #239, which is that issue.


catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action =
Expand Down
14 changes: 7 additions & 7 deletions servant-client/test/Servant/ClientSpec.hs
View file
Open in desktop
Expand Up @@ -90,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

type Api =
"get" :> Get '[JSON] Person
:<|> "deleteEmpty" :> Delete '[] ()
:<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
Expand All @@ -105,14 +105,14 @@ type Api =
ReqBody '[JSON] [(String, [Rational])] :>
Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
:<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
:<|> "deleteContentType" :> Delete '[JSON] ()
:<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
api :: Proxy Api
api = Proxy

server :: Application
server = serve api (
return alice
:<|> return ()
:<|> return NoContent
:<|> (\ name -> return $ Person name 0)
:<|> return
:<|> (\ name -> case name of
Expand All @@ -125,7 +125,7 @@ server = serve api (
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return ()
:<|> return NoContent
)


Expand Down Expand Up @@ -157,11 +157,11 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do
let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager
(left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right ()
(left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent

it "allows content type" $ \(_, baseUrl) -> do
let getDeleteContentType = getLast $ client api baseUrl manager
(left show <$> runExceptT getDeleteContentType) `shouldReturn` Right ()
(left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent

it "Servant.API.Capture" $ \(_, baseUrl) -> do
let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager
Expand Down Expand Up @@ -283,7 +283,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res

data WrappedApi where
WrappedApi :: (HasServer api, Server api ~ ExceptT ServantErr IO a,
WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a,
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is this kind-annotation better or needed?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It is needed (I needed to turn on PolyKinds somewhere). We could put it in HasServer itself, I guess?

HasClient api, Client api ~ ExceptT ServantError IO ()) =>
Proxy api -> WrappedApi

Expand Down
3 changes: 1 addition & 2 deletions servant-docs/src/Servant/Docs.hs
View file
Open in desktop
Expand Up @@ -41,8 +41,7 @@ module Servant.Docs
, ToCapture(..)

, -- * ADTs to represent an 'API'
Method(..)
, Endpoint, path, method, defEndpoint
Endpoint, path, method, defEndpoint
, API, apiIntros, apiEndpoints, emptyAPI
, DocCapture(..), capSymbol, capDesc
, DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind
Expand Down