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

Simplify verb combinators.

Browse source 
Create a single 'Verb' combinator with parameters for status code and
        method. Make existing combinators type synonyms of 'Verb'.
This commit is contained in:
Julian K. Arni 2015-11-27 02:05:34 +01:00
parent 3d0ae36189
commit cda8bcf17c
19 changed files with 279 additions and 602 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
@ -44,7 +45,7 @@ import Servant.Common.Req
-- | 'client' allows you to produce operations to query an API from a client. -- | 'client' allows you to produce operations to query an API from a client.
-- --
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books -- > 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 MyApi
-- > myApi = Proxy -- > myApi = Proxy
@ -118,62 +119,48 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
where p = unpack (toUrlPiece val) 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_ instance OVERLAPPABLE_
(MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where -- Note [Non-Empty Content Types]
type Client (Delete cts' a) = ExceptT ServantError IO a (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 = 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_ instance OVERLAPPING_
HasClient (Delete cts ()) where (ReflectMethod method) => HasClient (Verb method status cts ()) where
type Client (Delete cts ()) = ExceptT ServantError IO () type Client (Verb method status cts ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodDelete req baseurl manager void $ performRequestNoBody method req baseurl manager
where method = reflectMethod (Proxy :: Proxy method)
-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance OVERLAPPING_ instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) -- Note [Non-Empty Content Types]
) => HasClient (Delete cts' (Headers ls a)) where ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) ) => 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 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 return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , 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_ instance OVERLAPPING_
HasClient (Get (ct ': cts) ()) where ( BuildHeadersTo ls, ReflectMethod method
type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () ) => HasClient (Verb method status cts (Headers ls ())) where
clientWithRoute Proxy req baseurl manager = type Client (Verb method status cts (Headers ls ()))
performRequestNoBody H.methodGet req baseurl manager = ExceptT ServantError IO (Headers ls ())
-- | 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)
clientWithRoute Proxy req baseurl manager = do clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager let method = reflectMethod (Proxy :: Proxy method)
return $ Headers { getResponse = resp hdrs <- performRequestNoBody method req baseurl manager
return $ Headers { getResponse = ()
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
-- | If you use a 'Header' in one of your endpoints in your API, -- | If you use a 'Header' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'Header', -- an additional argument of the type specified by your 'Header',
@ -217,90 +204,6 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
where hname = symbolVal (Proxy :: Proxy sym) 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, -- | If you use a 'QueryParam' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'QueryParam', -- an additional argument of the type specified by your 'QueryParam',
@ -503,3 +406,20 @@ instance HasClient api => HasClient (IsSecure :> api) where
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) 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 turns generally means adding yet another instance (one
for empty and one for non-empty lists).
-}

19
servant-client/src/Servant/Common/Req.hs
View file

@ -142,7 +142,7 @@ performRequest reqMethod req reqHost manager = do
Right response -> do Right response -> do
let status = Client.responseStatus response let status = Client.responseStatus response
body = Client.responseBody response body = Client.responseBody response
hrds = Client.responseHeaders response hdrs = Client.responseHeaders response
status_code = statusCode status status_code = statusCode status
ct <- case lookup "Content-Type" $ Client.responseHeaders response of ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream" Nothing -> pure $ "application"//"octet-stream"
@ -151,23 +151,26 @@ performRequest reqMethod req reqHost manager = do
Just t' -> pure t' Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $ unless (status_code >= 200 && status_code < 300) $
throwE $ FailureResponse status ct body throwE $ FailureResponse status ct body
return (status_code, body, ct, hrds, response) return (status_code, body, ct, hdrs, response)
performRequestCT :: MimeUnrender ct result => 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 performRequestCT ct reqMethod req reqHost manager = do
let acceptCT = contentType ct let acceptCT = contentType ct
(_status, respBody, respCT, hrds, _response) <- (_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody 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 :: Method -> Req -> BaseUrl -> Manager
performRequestNoBody reqMethod req reqHost manager = -> ExceptT ServantError IO [HTTP.Header]
void $ performRequest reqMethod req reqHost manager performRequestNoBody reqMethod req reqHost manager = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager
return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action = catchConnectionError action =

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

@ -90,7 +90,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
type Api = type Api =
"get" :> Get '[JSON] Person "get" :> Get '[JSON] Person
:<|> "deleteEmpty" :> Delete '[] () :<|> "deleteEmpty" :> Delete '[JSON] ()
:<|> "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
@ -283,7 +283,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where data WrappedApi where
WrappedApi :: (HasServer api, Server api ~ ExceptT ServantErr IO a, WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a,
HasClient api, Client api ~ ExceptT ServantError IO ()) => HasClient api, Client api ~ ExceptT ServantError IO ()) =>
Proxy api -> WrappedApi Proxy api -> WrappedApi

63
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -476,8 +476,8 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
-- | Synthesise a sample value of a type, encoded in the specified media types. -- | Synthesise a sample value of a type, encoded in the specified media types.
sampleByteString sampleByteString
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
=> Proxy ctypes => Proxy (ct ': cts)
-> Proxy a -> Proxy a
-> [(M.MediaType, ByteString)] -> [(M.MediaType, ByteString)]
sampleByteString ctypes@Proxy Proxy = sampleByteString ctypes@Proxy Proxy =
@ -486,8 +486,8 @@ sampleByteString ctypes@Proxy Proxy =
-- | Synthesise a list of sample values of a particular type, encoded in the -- | Synthesise a list of sample values of a particular type, encoded in the
-- specified media types. -- specified media types.
sampleByteStrings sampleByteStrings
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
=> Proxy ctypes => Proxy (ct ': cts)
-> Proxy a -> Proxy a
-> [(Text, M.MediaType, ByteString)] -> [(Text, M.MediaType, ByteString)]
sampleByteStrings ctypes@Proxy Proxy = sampleByteStrings ctypes@Proxy Proxy =
@ -689,21 +689,21 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
instance OVERLAPPABLE_ instance OVERLAPPABLE_
(ToSample a, IsNonEmpty cts, AllMimeRender cts a) (ToSample a, AllMimeRender (ct ': cts) a)
=> HasDocs (Delete cts a) where => HasDocs (Delete (ct ': cts) a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocDELETE where endpoint' = endpoint & method .~ DocDELETE
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t & response.respTypes .~ allMime t
t = Proxy :: Proxy cts t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance OVERLAPPING_ instance OVERLAPPING_
(ToSample a, IsNonEmpty cts, AllMimeRender cts a (ToSample a, AllMimeRender (ct ': cts) a
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Delete cts (Headers ls a)) where => HasDocs (Delete (ct ': cts) (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
@ -712,25 +712,26 @@ instance OVERLAPPING_
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t & response.respTypes .~ allMime t
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
t = Proxy :: Proxy cts t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance OVERLAPPABLE_ instance OVERLAPPABLE_
(ToSample a, IsNonEmpty cts, AllMimeRender cts a) (ToSample a, AllMimeRender (ct ': cts) a)
=> HasDocs (Get cts a) where => HasDocs (Get (ct ': cts) a) where
>>>>>>> Simplify verb combinators.
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocGET where endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t & response.respTypes .~ allMime t
t = Proxy :: Proxy cts t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance OVERLAPPING_ instance OVERLAPPING_
(ToSample a, IsNonEmpty cts, AllMimeRender cts a (ToSample a, AllMimeRender (ct ': cts) a
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Get cts (Headers ls a)) where => HasDocs (Get (ct ': cts) (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
@ -739,7 +740,7 @@ instance OVERLAPPING_
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t & response.respTypes .~ allMime t
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
t = Proxy :: Proxy cts t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (KnownSymbol sym, HasDocs sublayout) instance (KnownSymbol sym, HasDocs sublayout)
@ -752,8 +753,8 @@ instance (KnownSymbol sym, HasDocs sublayout)
headername = pack $ symbolVal (Proxy :: Proxy sym) headername = pack $ symbolVal (Proxy :: Proxy sym)
instance OVERLAPPABLE_ instance OVERLAPPABLE_
(ToSample a, IsNonEmpty cts, AllMimeRender cts a) (ToSample a, AllMimeRender (ct ': cts) a)
=> HasDocs (Post cts a) where => HasDocs (Post (ct ': cts) a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
@ -761,13 +762,13 @@ instance OVERLAPPABLE_
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t & response.respTypes .~ allMime t
& response.respStatus .~ 201 & response.respStatus .~ 201
t = Proxy :: Proxy cts t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance OVERLAPPING_ instance OVERLAPPING_
(ToSample a, IsNonEmpty cts, AllMimeRender cts a (ToSample a, AllMimeRender (ct ': cts) a
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Post cts (Headers ls a)) where => HasDocs (Post (ct ': cts) (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
@ -777,12 +778,12 @@ instance OVERLAPPING_
& response.respTypes .~ allMime t & response.respTypes .~ allMime t
& response.respStatus .~ 201 & response.respStatus .~ 201
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
t = Proxy :: Proxy cts t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance OVERLAPPABLE_ instance OVERLAPPABLE_
(ToSample a, IsNonEmpty cts, AllMimeRender cts a) (ToSample a, AllMimeRender (ct ': cts) a)
=> HasDocs (Put cts a) where => HasDocs (Put (ct ': cts) a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
@ -790,13 +791,13 @@ instance OVERLAPPABLE_
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ allMime t & response.respTypes .~ allMime t
& response.respStatus .~ 200 & response.respStatus .~ 200
t = Proxy :: Proxy cts t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance OVERLAPPING_ instance OVERLAPPING_
( ToSample a, IsNonEmpty cts, AllMimeRender cts a, ( ToSample a, AllMimeRender (ct ': cts) a,
AllHeaderSamples ls , GetHeaders (HList ls) ) AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Put cts (Headers ls a)) where => HasDocs (Put (ct ': cts) (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
@ -806,7 +807,7 @@ instance OVERLAPPING_
& response.respTypes .~ allMime t & response.respTypes .~ allMime t
& response.respStatus .~ 200 & response.respStatus .~ 200
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
t = Proxy :: Proxy cts t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
@ -849,8 +850,8 @@ instance HasDocs Raw where
-- example data. However, there's no reason to believe that the instances of -- example data. However, there's no reason to believe that the instances of
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
-- both are even defined) for any particular type. -- both are even defined) for any particular type.
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout) instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout)
=> HasDocs (ReqBody cts a :> sublayout) where => HasDocs (ReqBody (ct ': cts) a :> sublayout) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action') docsFor sublayoutP (endpoint, action')
@ -858,7 +859,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
where sublayoutP = Proxy :: Proxy sublayout where sublayoutP = Proxy :: Proxy sublayout
action' = action & rqbody .~ sampleByteString t p action' = action & rqbody .~ sampleByteString t p
& rqtypes .~ allMime t & rqtypes .~ allMime t
t = Proxy :: Proxy cts t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where

249
servant-server/src/Servant/Server/Internal.hs
View file

@ -21,26 +21,33 @@ module Servant.Server.Internal
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except (ExceptT)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (ConvertibleStrings, cs, (<>)) import Data.String.Conversions (cs, (<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Typeable import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
import Network.HTTP.Types hiding (Header, ResponseHeaders) symbolVal)
import Network.Socket (SockAddr) import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Wai (Application, lazyRequestBody, import Network.Socket (SockAddr)
rawQueryString, requestHeaders, import Network.Wai (Application, Request, Response,
requestMethod, responseLBS, remoteHost, httpVersion, isSecure,
isSecure, vault, httpVersion, Response, lazyRequestBody, pathInfo,
Request, pathInfo) rawQueryString, remoteHost,
requestHeaders, requestMethod,
responseLBS, vault)
import Web.HttpApiData (FromHttpApiData)
import Web.HttpApiData.Internal (parseHeaderMaybe,
parseQueryParamMaybe,
parseUrlPieceMaybe)
import Servant.API ((:<|>) (..), (:>), Capture, import Servant.API ((:<|>) (..), (:>), Capture,
Delete, Get, Header, Verb, ReflectMethod(reflectMethod),
IsSecure(..), Patch, Post, Put, IsSecure(..), Header,
QueryFlag, QueryParam, QueryParams, QueryFlag, QueryParam, QueryParams,
Raw, RemoteHost, ReqBody, Vault) Raw, RemoteHost, ReqBody, Vault)
import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ContentTypes (AcceptHeader (..),
@ -55,8 +62,6 @@ import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
import Web.HttpApiData (FromHttpApiData)
import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe)
class HasServer layout where class HasServer layout where
type ServerT layout (m :: * -> *) :: * type ServerT layout (m :: * -> *) :: *
@ -129,12 +134,12 @@ allowedMethodHead method request = method == methodGet && requestMethod request
allowedMethod :: Method -> Request -> Bool allowedMethod :: Method -> Request -> Bool
allowedMethod method request = allowedMethodHead method request || requestMethod request == method allowedMethod method request = allowedMethodHead method request || requestMethod request == method
processMethodRouter :: forall a. ConvertibleStrings a B.ByteString processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
=> Maybe (a, BL.ByteString) -> Status -> Method
-> Maybe [(HeaderName, B.ByteString)] -> Maybe [(HeaderName, B.ByteString)]
-> Request -> RouteResult Response -> Request -> RouteResult Response
processMethodRouter handleA status method headers request = case handleA of processMethodRouter handleA status method headers request = case handleA of
Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
Just (_, "") -> Route $ responseLBS status204 (fromMaybe [] headers) ""
Just (contentT, body) -> Route $ responseLBS status hdrs bdy Just (contentT, body) -> Route $ responseLBS status hdrs bdy
where where
bdy = if allowedMethodHead method request then "" else body bdy = if allowedMethodHead method request then "" else body
@ -160,7 +165,7 @@ methodRouter method proxy status action = LeafRouter route'
| pathIsEmpty request = | pathIsEmpty request =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH `addAcceptCheck` acceptCheck proxy accH
) respond $ \ output -> do ) respond $ \ output -> do
let handleA = handleAcceptH proxy (AcceptHeader accH) output let handleA = handleAcceptH proxy (AcceptHeader accH) output
processMethodRouter handleA status method Nothing request processMethodRouter handleA status method Nothing request
@ -176,95 +181,34 @@ methodRouterHeaders method proxy status action = LeafRouter route'
| pathIsEmpty request = | pathIsEmpty request =
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
in runAction (action `addMethodCheck` methodCheck method request in runAction (action `addMethodCheck` methodCheck method request
`addAcceptCheck` acceptCheck proxy accH `addAcceptCheck` acceptCheck proxy accH
) respond $ \ output -> do ) respond $ \ output -> do
let headers = getHeaders output let headers = getHeaders output
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
processMethodRouter handleA status method (Just headers) request processMethodRouter handleA status method (Just headers) request
| otherwise = respond $ Fail err404 | otherwise = respond $ Fail err404
methodRouterEmpty :: Method
-> Delayed (ExceptT ServantErr IO ())
-> Router
methodRouterEmpty method action = LeafRouter route'
where
route' request respond
| pathIsEmpty request = do
runAction (addMethodCheck action (methodCheck method request)) respond $ \ () ->
Route $! responseLBS noContent204 [] ""
| otherwise = respond $ Fail err404
-- | If you have a 'Delete' endpoint in your API,
-- the handler for this endpoint is meant to delete
-- a resource.
--
-- The code of the handler will, just like
-- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and
-- 'Servant.API.Put.Put', run in @ExceptT ServantErr IO ()@.
-- The 'Int' represents the status code and the 'String' a message
-- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to
-- painlessly error out if the conditions for a successful deletion
-- are not met.
instance OVERLAPPABLE_ instance OVERLAPPABLE_
( AllCTRender ctypes a ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
) => HasServer (Delete ctypes a) where ) => HasServer (Verb method status ctypes a) where
type ServerT (Delete ctypes a) m = m a type ServerT (Verb method status ctypes a) m = m a
route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 route Proxy = methodRouter method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance OVERLAPPING_ instance OVERLAPPING_
HasServer (Delete ctypes ()) where instance
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
, GetHeaders (Headers h a)
) => HasServer (Verb method status ctypes (Headers h a)) where
type ServerT (Delete ctypes ()) m = m () type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
route Proxy = methodRouterEmpty methodDelete route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
-- Add response headers status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance OVERLAPPING_
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Delete ctypes (Headers h v)) where
type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
-- | When implementing the handler for a 'Get' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
-- and 'Servant.API.Put.Put', the handler code runs in the
-- @ExceptT ServantErr IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
-- to quickly fail if some conditions are not met.
--
-- If successfully returning a value, we use the type-level list, combined
-- with the request's @Accept@ header, to encode the value for you
-- (returning a status code of 200). If there was no @Accept@ header or it
-- was @*\/\*@, we return encode using the first @Content-Type@ type on the
-- list.
instance OVERLAPPABLE_
( AllCTRender ctypes a ) => HasServer (Get ctypes a) where
type ServerT (Get ctypes a) m = m a
route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
-- '()' ==> 204 No Content
instance OVERLAPPING_
HasServer (Get ctypes ()) where
type ServerT (Get ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodGet
-- Add response headers
instance OVERLAPPING_
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Get ctypes (Headers h v)) where
type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
-- | If you use 'Header' in one of the endpoints for your API, -- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -297,113 +241,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
in route (Proxy :: Proxy sublayout) (passToServer subserver mheader) in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
where str = fromString $ symbolVal (Proxy :: Proxy sym) where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | When implementing the handler for a 'Post' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
-- and 'Servant.API.Put.Put', the handler code runs in the
-- @ExceptT ServantErr IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
-- to quickly fail if some conditions are not met.
--
-- If successfully returning a value, we use the type-level list, combined
-- with the request's @Accept@ header, to encode the value for you
-- (returning a status code of 201). If there was no @Accept@ header or it
-- was @*\/\*@, we return encode using the first @Content-Type@ type on the
-- list.
instance OVERLAPPABLE_
( AllCTRender ctypes a
) => HasServer (Post ctypes a) where
type ServerT (Post ctypes a) m = m a
route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
instance OVERLAPPING_
HasServer (Post ctypes ()) where
type ServerT (Post ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodPost
-- Add response headers
instance OVERLAPPING_
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Post ctypes (Headers h v)) where
type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
-- | When implementing the handler for a 'Put' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
-- and 'Servant.API.Post.Post', the handler code runs in the
-- @ExceptT ServantErr IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
-- to quickly fail if some conditions are not met.
--
-- If successfully returning a value, we use the type-level list, combined
-- with the request's @Accept@ header, to encode the value for you
-- (returning a status code of 200). If there was no @Accept@ header or it
-- was @*\/\*@, we return encode using the first @Content-Type@ type on the
-- list.
instance OVERLAPPABLE_
( AllCTRender ctypes a) => HasServer (Put ctypes a) where
type ServerT (Put ctypes a) m = m a
route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
instance OVERLAPPING_
HasServer (Put ctypes ()) where
type ServerT (Put ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodPut
-- Add response headers
instance OVERLAPPING_
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Put ctypes (Headers h v)) where
type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
-- | When implementing the handler for a 'Patch' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
-- and 'Servant.API.Put.Put', the handler code runs in the
-- @ExceptT ServantErr IO@ monad, where the 'Int' represents
-- the status code and the 'String' a message, returned in case of
-- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE'
-- to quickly fail if some conditions are not met.
--
-- If successfully returning a value, we just require that its type has
-- a 'ToJSON' instance and servant takes care of encoding it for you,
-- yielding status code 200 along the way.
instance OVERLAPPABLE_
( AllCTRender ctypes a) => HasServer (Patch ctypes a) where
type ServerT (Patch ctypes a) m = m a
route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
instance OVERLAPPING_
HasServer (Patch ctypes ()) where
type ServerT (Patch ctypes ()) m = m ()
route Proxy = methodRouterEmpty methodPatch
-- Add response headers
instance OVERLAPPING_
( GetHeaders (Headers h v), AllCTRender ctypes v
) => HasServer (Patch ctypes (Headers h v)) where
type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
-- that takes an argument of type @'Maybe' 'Text'@. -- that takes an argument of type @'Maybe' 'Text'@.

2
servant-server/test/Servant/Server/ErrorSpec.hs
View file

@ -162,7 +162,7 @@ errorRetrySpec = describe "Handler search"
it "should continue when URLs don't match" $ do it "should continue when URLs don't match" $ do
request methodPost "" [jsonCT, jsonAccept] jsonBody request methodPost "" [jsonCT, jsonAccept] jsonBody
`shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) } `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) }
it "should continue when methods don't match" $ do it "should continue when methods don't match" $ do
request methodGet "a" [jsonCT, jsonAccept] jsonBody request methodGet "a" [jsonCT, jsonAccept] jsonBody

2
servant-server/test/Servant/Server/Internal/EnterSpec.hs
View file

@ -52,7 +52,7 @@ enterSpec = describe "Enter" $ do
it "allows running arbitrary monads" $ do it "allows running arbitrary monads" $ do
get "int" `shouldRespondWith` "1797" get "int" `shouldRespondWith` "1797"
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 } post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
with (return (serve combinedAPI combinedReaderServer)) $ do with (return (serve combinedAPI combinedReaderServer)) $ do
it "allows combnation of enters" $ do it "allows combnation of enters" $ do

48
servant-server/test/Servant/ServerSpec.hs
View file

@ -130,15 +130,21 @@ captureSpec = do
type GetApi = Get '[JSON] Person type GetApi = Get '[JSON] Person
:<|> "empty" :> Get '[] () :<|> "empty" :> Get '[JSON] ()
:<|> "post" :> Post '[] () :<|> "emptyWithHeaders" :> Get '[JSON] (Headers '[Header "H" Int] ())
:<|> "post" :> Post '[JSON] ()
getApi :: Proxy GetApi getApi :: Proxy GetApi
getApi = Proxy getApi = Proxy
getSpec :: Spec getSpec :: Spec
getSpec = do getSpec = do
describe "Servant.API.Get" $ do describe "Servant.API.Get" $ do
let server = return alice :<|> return () :<|> return () let server = return alice
:<|> return ()
:<|> return (addHeader 5 ())
:<|> return ()
with (return $ serve getApi server) $ do with (return $ serve getApi server) $ do
it "allows to GET a Person" $ do it "allows to GET a Person" $ do
@ -150,8 +156,8 @@ getSpec = do
post "/" "" `shouldRespondWith` 405 post "/" "" `shouldRespondWith` 405
post "/empty" "" `shouldRespondWith` 405 post "/empty" "" `shouldRespondWith` 405
it "returns 204 if the type is '()'" $ do it "returns headers" $ do
get "/empty" `shouldRespondWith` ""{ matchStatus = 204 } get "/emptyWithHeaders" `shouldRespondWith` 204 { matchHeaders = [ "H" <:> "5" ] }
it "returns 406 if the Accept header is not supported" $ do it "returns 406 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
@ -161,7 +167,10 @@ getSpec = do
headSpec :: Spec headSpec :: Spec
headSpec = do headSpec = do
describe "Servant.API.Head" $ do describe "Servant.API.Head" $ do
let server = return alice :<|> return () :<|> return () let server = return alice
:<|> return ()
:<|> return (addHeader 5 ())
:<|> return ()
with (return $ serve getApi server) $ do with (return $ serve getApi server) $ do
it "allows to GET a Person" $ do it "allows to GET a Person" $ do
@ -177,10 +186,6 @@ headSpec = do
post "/" "" `shouldRespondWith` 405 post "/" "" `shouldRespondWith` 405
post "/empty" "" `shouldRespondWith` 405 post "/empty" "" `shouldRespondWith` 405
it "returns 204 if the type is '()'" $ do
response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
return response `shouldRespondWith` ""{ matchStatus = 204 }
it "returns 406 if the Accept header is not supported" $ do it "returns 406 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 406 `shouldRespondWith` 406
@ -272,7 +277,7 @@ queryParamSpec = do
type PostApi = type PostApi =
ReqBody '[JSON] Person :> Post '[JSON] Integer ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "empty" :> Post '[] () :<|> "empty" :> Post '[JSON] ()
postApi :: Proxy PostApi postApi :: Proxy PostApi
postApi = Proxy postApi = Proxy
@ -287,25 +292,22 @@ postSpec = do
it "allows to POST a Person" $ do it "allows to POST a Person" $ do
post' "/" (encode alice) `shouldRespondWith` "42"{ post' "/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201 matchStatus = 200
} }
it "allows alternative routes if all have request bodies" $ do it "allows alternative routes if all have request bodies" $ do
post' "/bla" (encode alice) `shouldRespondWith` "42"{ post' "/bla" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201 matchStatus = 200
} }
it "handles trailing '/' gracefully" $ do it "handles trailing '/' gracefully" $ do
post' "/bla/" (encode alice) `shouldRespondWith` "42"{ post' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201 matchStatus = 200
} }
it "correctly rejects invalid request bodies with status 400" $ do it "correctly rejects invalid request bodies with status 400" $ do
post' "/" "some invalid body" `shouldRespondWith` 400 post' "/" "some invalid body" `shouldRespondWith` 400
it "returns 204 if the type is '()'" $ do
post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the request body media type is unsupported" $ do it "responds with 415 if the request body media type is unsupported" $ do
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/nonsense")] , "application/nonsense")]
@ -314,7 +316,7 @@ postSpec = do
type PutApi = type PutApi =
ReqBody '[JSON] Person :> Put '[JSON] Integer ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
:<|> "empty" :> Put '[] () :<|> "empty" :> Put '[JSON] ()
putApi :: Proxy PutApi putApi :: Proxy PutApi
putApi = Proxy putApi = Proxy
@ -345,9 +347,6 @@ putSpec = do
it "correctly rejects invalid request bodies with status 400" $ do it "correctly rejects invalid request bodies with status 400" $ do
put' "/" "some invalid body" `shouldRespondWith` 400 put' "/" "some invalid body" `shouldRespondWith` 400
it "returns 204 if the type is '()'" $ do
put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the request body media type is unsupported" $ do it "responds with 415 if the request body media type is unsupported" $ do
let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
, "application/nonsense")] , "application/nonsense")]
@ -356,7 +355,7 @@ putSpec = do
type PatchApi = type PatchApi =
ReqBody '[JSON] Person :> Patch '[JSON] Integer ReqBody '[JSON] Person :> Patch '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
:<|> "empty" :> Patch '[] () :<|> "empty" :> Patch '[JSON] ()
patchApi :: Proxy PatchApi patchApi :: Proxy PatchApi
patchApi = Proxy patchApi = Proxy
@ -387,9 +386,6 @@ patchSpec = do
it "correctly rejects invalid request bodies with status 400" $ do it "correctly rejects invalid request bodies with status 400" $ do
patch' "/" "some invalid body" `shouldRespondWith` 400 patch' "/" "some invalid body" `shouldRespondWith` 400
it "returns 204 if the type is '()'" $ do
patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the request body media type is unsupported" $ do it "responds with 415 if the request body media type is unsupported" $ do
let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
, "application/nonsense")] , "application/nonsense")]
@ -505,7 +501,7 @@ responseHeadersSpec :: Spec
responseHeadersSpec = describe "ResponseHeaders" $ do responseHeadersSpec = describe "ResponseHeaders" $ do
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)] let methods = [(methodGet, 200), (methodPost, 200), (methodPut, 200), (methodPatch, 200)]
it "includes the headers in the response" $ it "includes the headers in the response" $
forM_ methods $ \(method, expected) -> forM_ methods $ \(method, expected) ->

7
servant-server/test/Servant/Utils/StaticFilesSpec.hs
View file

@ -15,12 +15,7 @@ import System.IO.Temp (withSystemTempDirectory)
import Test.Hspec (Spec, around_, describe, it) import Test.Hspec (Spec, around_, describe, it)
import Test.Hspec.Wai (get, shouldRespondWith, with) import Test.Hspec.Wai (get, shouldRespondWith, with)
import Servant.API (JSON) import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
import Servant.API.Alternative ((:<|>) ((:<|>)))
import Servant.API.Capture (Capture)
import Servant.API.Get (Get)
import Servant.API.Raw (Raw)
import Servant.API.Sub ((:>))
import Servant.Server (Server, serve) import Servant.Server (Server, serve)
import Servant.ServerSpec (Person (Person)) import Servant.ServerSpec (Person (Person))
import Servant.Utils.StaticFiles (serveDirectory) import Servant.Utils.StaticFiles (serveDirectory)

6
servant/servant.cabal
View file

@ -29,14 +29,9 @@ library
Servant.API.Alternative Servant.API.Alternative
Servant.API.Capture Servant.API.Capture
Servant.API.ContentTypes Servant.API.ContentTypes
Servant.API.Delete
Servant.API.Get
Servant.API.Header Servant.API.Header
Servant.API.HttpVersion Servant.API.HttpVersion
Servant.API.IsSecure Servant.API.IsSecure
Servant.API.Patch
Servant.API.Post
Servant.API.Put
Servant.API.QueryParam Servant.API.QueryParam
Servant.API.Raw Servant.API.Raw
Servant.API.RemoteHost Servant.API.RemoteHost
@ -44,6 +39,7 @@ library
Servant.API.ResponseHeaders Servant.API.ResponseHeaders
Servant.API.Sub Servant.API.Sub
Servant.API.Vault Servant.API.Vault
Servant.API.Verbs
Servant.Utils.Links Servant.Utils.Links
build-depends: build-depends:
base >=4.7 && <5 base >=4.7 && <5

23
servant/src/Servant/API.hs
View file

@ -25,16 +25,7 @@ module Servant.API (
-- | Access the location for arbitrary data to be shared by applications and middleware -- | Access the location for arbitrary data to be shared by applications and middleware
-- * Actual endpoints, distinguished by HTTP method -- * Actual endpoints, distinguished by HTTP method
module Servant.API.Get, module Servant.API.Verbs,
-- | @GET@ requests
module Servant.API.Post,
-- | @POST@ requests
module Servant.API.Delete,
-- | @DELETE@ requests
module Servant.API.Put,
-- | @PUT@ requests
module Servant.API.Patch,
-- | @PATCH@ requests
-- * Content Types -- * Content Types
module Servant.API.ContentTypes, module Servant.API.ContentTypes,
@ -64,14 +55,9 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
MimeRender (..), MimeRender (..),
MimeUnrender (..), OctetStream, MimeUnrender (..), OctetStream,
PlainText, ToFormUrlEncoded (..)) PlainText, ToFormUrlEncoded (..))
import Servant.API.Delete (Delete)
import Servant.API.Get (Get)
import Servant.API.Header (Header (..)) import Servant.API.Header (Header (..))
import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.HttpVersion (HttpVersion (..))
import Servant.API.IsSecure (IsSecure (..)) import Servant.API.IsSecure (IsSecure (..))
import Servant.API.Patch (Patch)
import Servant.API.Post (Post)
import Servant.API.Put (Put)
import Servant.API.QueryParam (QueryFlag, QueryParam, import Servant.API.QueryParam (QueryFlag, QueryParam,
QueryParams) QueryParams)
import Servant.API.Raw (Raw) import Servant.API.Raw (Raw)
@ -84,7 +70,10 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader),
getHeadersHList, getResponse) getHeadersHList, getResponse)
import Servant.API.Sub ((:>)) import Servant.API.Sub ((:>))
import Servant.API.Vault (Vault) import Servant.API.Vault (Vault)
import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) import Servant.API.Verbs (Delete, Get, Patch, Post, Put,
ReflectMethod (reflectMethod),
Verb)
import Servant.Utils.Links (HasLink (..), IsElem, IsElem', import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
URI (..), safeLink) URI (..), safeLink)
import Web.HttpApiData (FromHttpApiData (..),
ToHttpApiData (..))

66
servant/src/Servant/API/ContentTypes.hs
View file

@ -2,6 +2,7 @@
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -10,6 +11,9 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_HADDOCK not-home #-}
-- | A collection of basic Content-Types (also known as Internet Media -- | A collection of basic Content-Types (also known as Internet Media
@ -19,7 +23,7 @@
-- --
-- Content-Types are used in `ReqBody` and the method combinators: -- Content-Types are used in `ReqBody` and the method combinators:
-- --
-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book -- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book
-- --
-- Meaning the endpoint accepts requests of Content-Type @application/json@ -- Meaning the endpoint accepts requests of Content-Type @application/json@
-- or @text/plain;charset-utf8@, and returns data in either one of those -- or @text/plain;charset-utf8@, and returns data in either one of those
@ -62,7 +66,6 @@ module Servant.API.ContentTypes
, AllMimeUnrender(..) , AllMimeUnrender(..)
, FromFormUrlEncoded(..) , FromFormUrlEncoded(..)
, ToFormUrlEncoded(..) , ToFormUrlEncoded(..)
, IsNonEmpty
, eitherDecodeLenient , eitherDecodeLenient
, canHandleAcceptH , canHandleAcceptH
) where ) where
@ -91,7 +94,7 @@ import qualified Data.Text.Encoding as TextS
import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy as TextL
import qualified Data.Text.Lazy.Encoding as TextL import qualified Data.Text.Lazy.Encoding as TextL
import Data.Typeable import Data.Typeable
import GHC.Exts (Constraint) import GHC.Generics (Generic)
import qualified Network.HTTP.Media as M import qualified Network.HTTP.Media as M
import Network.URI (escapeURIString, import Network.URI (escapeURIString,
isUnreserved, unEscapeString) isUnreserved, unEscapeString)
@ -137,7 +140,7 @@ instance Accept OctetStream where
contentType _ = "application" M.// "octet-stream" contentType _ = "application" M.// "octet-stream"
newtype AcceptHeader = AcceptHeader BS.ByteString newtype AcceptHeader = AcceptHeader BS.ByteString
deriving (Eq, Show) deriving (Eq, Show, Read, Typeable, Generic)
-- * Render (serializing) -- * Render (serializing)
@ -159,19 +162,22 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
class Accept ctype => MimeRender ctype a where class Accept ctype => MimeRender ctype a where
mimeRender :: Proxy ctype -> a -> ByteString mimeRender :: Proxy ctype -> a -> ByteString
class (AllMimeRender list a) => AllCTRender (list :: [*]) a where class (AllMime list) => AllCTRender (list :: [*]) a where
-- If the Accept header can be matched, returns (Just) a tuple of the -- If the Accept header can be matched, returns (Just) a tuple of the
-- Content-Type and response (serialization of @a@ into the appropriate -- Content-Type and response (serialization of @a@ into the appropriate
-- mimetype). -- mimetype).
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
where pctyps = Proxy :: Proxy ctyps where pctyps = Proxy :: Proxy (ct ': cts)
amrs = allMimeRender pctyps val amrs = allMimeRender pctyps val
lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs
-------------------------------------------------------------------------- --------------------------------------------------------------------------
-- * Unrender -- * Unrender
@ -199,14 +205,13 @@ instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
class Accept ctype => MimeUnrender ctype a where class Accept ctype => MimeUnrender ctype a where
mimeUnrender :: Proxy ctype -> ByteString -> Either String a mimeUnrender :: Proxy ctype -> ByteString -> Either String a
class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where class AllCTUnrender (list :: [*]) a where
handleCTypeH :: Proxy list handleCTypeH :: Proxy list
-> ByteString -- Content-Type header -> ByteString -- Content-Type header
-> ByteString -- Request body -> ByteString -- Request body
-> Maybe (Either String a) -> Maybe (Either String a)
instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
) => AllCTUnrender ctyps a where
handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
@ -247,8 +252,7 @@ instance ( MimeRender ctyp a
where pctyp = Proxy :: Proxy ctyp where pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy (ctyp' ': ctyps) pctyps = Proxy :: Proxy (ctyp' ': ctyps)
instance AllMimeRender '[] () where
instance AllMimeRender '[] a where
allMimeRender _ _ = [] allMimeRender _ _ = []
-------------------------------------------------------------------------- --------------------------------------------------------------------------
@ -270,21 +274,25 @@ instance ( MimeUnrender ctyp a
where pctyp = Proxy :: Proxy ctyp where pctyp = Proxy :: Proxy ctyp
pctyps = Proxy :: Proxy ctyps pctyps = Proxy :: Proxy ctyps
type family IsNonEmpty (list :: [*]) :: Constraint where
IsNonEmpty (x ': xs) = ()
-------------------------------------------------------------------------- --------------------------------------------------------------------------
-- * MimeRender Instances -- * MimeRender Instances
-- | `encode` -- | `encode`
instance ToJSON a => MimeRender JSON a where instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
ToJSON a => MimeRender JSON a where
mimeRender _ = encode mimeRender _ = encode
-- | @encodeFormUrlEncoded . toFormUrlEncoded@ -- | @encodeFormUrlEncoded . toFormUrlEncoded@
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
-- holds if every element of x is non-null (i.e., not @("", "")@) -- holds if every element of x is non-null (i.e., not @("", "")@)
instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
-- | `TextL.encodeUtf8` -- | `TextL.encodeUtf8`
@ -307,6 +315,26 @@ instance MimeRender OctetStream ByteString where
instance MimeRender OctetStream BS.ByteString where instance MimeRender OctetStream BS.ByteString where
mimeRender _ = fromStrict mimeRender _ = fromStrict
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender JSON () where
mimeRender _ _ = ""
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender PlainText () where
mimeRender _ _ = ""
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
MimeRender OctetStream () where
mimeRender _ _ = ""
-------------------------------------------------------------------------- --------------------------------------------------------------------------
-- * MimeUnrender Instances -- * MimeUnrender Instances

24
servant/src/Servant/API/Delete.hs
View file

@ -1,24 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Delete (Delete) where
import Data.Typeable (Typeable)
-- | Combinator for DELETE requests.
--
-- Example:
--
-- >>> -- DELETE /books/:isbn
-- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete '[] ()
data Delete (contentTypes :: [*]) a
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

22
servant/src/Servant/API/Get.hs
View file

@ -1,22 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Get (Get) where
import Data.Typeable (Typeable)
-- | Endpoint for simple GET requests. Serves the result as JSON.
--
-- Example:
--
-- >>> type MyApi = "books" :> Get '[JSON] [Book]
data Get (contentTypes :: [*]) a
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

29
servant/src/Servant/API/Patch.hs
View file

@ -1,29 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Patch (Patch) where
import Data.Typeable (Typeable)
-- | Endpoint for PATCH requests. The type variable represents the type of the
-- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for
-- that).
--
-- If the HTTP response is empty, only () is supported.
--
-- Example:
--
-- >>> -- PATCH /books
-- >>> -- with a JSON encoded Book as the request body
-- >>> -- returning the just-created Book
-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book
data Patch (contentTypes :: [*]) a
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

27
servant/src/Servant/API/Post.hs
View file

@ -1,27 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Post (Post) where
import Data.Typeable (Typeable)
-- | Endpoint for POST requests. The type variable represents the type of the
-- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for
-- that).
--
-- Example:
--
-- >>> -- POST /books
-- >>> -- with a JSON encoded Book as the request body
-- >>> -- returning the just-created Book
-- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
data Post (contentTypes :: [*]) a
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

25
servant/src/Servant/API/Put.hs
View file

@ -1,25 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Put (Put) where
import Data.Typeable (Typeable)
-- | Endpoint for PUT requests, usually used to update a ressource.
-- The type @a@ is the type of the response body that's returned.
--
-- Example:
--
-- >>> -- PUT /books/:isbn
-- >>> -- with a Book as request body, returning the updated Book
-- >>> type MyApi = "books" :> Capture "isbn" Text :> ReqBody '[JSON] Book :> Put '[JSON] Book
data Put (contentTypes :: [*]) a
deriving Typeable
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Book
-- >>> instance ToJSON Book where { toJSON = undefined }

60
servant/src/Servant/API/Verbs.hs Normal file
View file

@ -0,0 +1,60 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
module Servant.API.Verbs where
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import GHC.TypeLits (Nat)
import Network.HTTP.Types.Method (Method, StdMethod (..),
methodDelete, methodGet, methodHead,
methodPatch, methodPost, methodPut)
-- | @Verb@ is a general type for representing HTTP verbs/methods. For
-- convenience, type synonyms for each verb with a 200 response code are
-- provided, but you are free to define your own:
--
-- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a
data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a
deriving (Typeable, Generic)
-- 'GET' with 200 status code.
type Get contentTypes a = Verb 'GET 200 contentTypes a
-- 'POST' with 200 status code.
type Post contentTypes a = Verb 'POST 200 contentTypes a
-- 'PUT' with 200 status code.
type Put contentTypes a = Verb 'PUT 200 contentTypes a
-- 'DELETE' with 200 status code.
type Delete contentTypes a = Verb 'DELETE 200 contentTypes a
-- 'PATCH' with 200 status code.
type Patch contentTypes a = Verb 'PATCH 200 contentTypes a
-- 'HEAD' with 200 status code.
type Head contentTypes a = Verb 'HEAD 200 contentTypes a
class ReflectMethod a where
reflectMethod :: proxy a -> Method
instance ReflectMethod 'GET where
reflectMethod _ = methodGet
instance ReflectMethod 'POST where
reflectMethod _ = methodPost
instance ReflectMethod 'PUT where
reflectMethod _ = methodPut
instance ReflectMethod 'DELETE where
reflectMethod _ = methodDelete
instance ReflectMethod 'PATCH where
reflectMethod _ = methodPatch
instance ReflectMethod 'HEAD where
reflectMethod _ = methodHead

37
servant/src/Servant/Utils/Links.hs
View file

@ -74,7 +74,9 @@
-- >>> safeLink api bad_link -- >>> safeLink api bad_link
-- ... -- ...
-- Could not deduce (Or -- Could not deduce (Or
-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int)) -- (IsElem'
-- (Verb 'Network.HTTP.Types.Method.DELETE 200 '[JSON] ())
-- (Verb 'Network.HTTP.Types.Method.GET 200 '[JSON] Int))
-- (IsElem' -- (IsElem'
-- ("hello" :> Delete '[JSON] ()) -- ("hello" :> Delete '[JSON] ())
-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ())))) -- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))
@ -119,11 +121,7 @@ import Servant.API.Capture ( Capture )
import Servant.API.ReqBody ( ReqBody ) import Servant.API.ReqBody ( ReqBody )
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
import Servant.API.Header ( Header ) import Servant.API.Header ( Header )
import Servant.API.Get ( Get ) import Servant.API.Verbs ( Verb )
import Servant.API.Post ( Post )
import Servant.API.Put ( Put )
import Servant.API.Patch ( Patch )
import Servant.API.Delete ( Delete )
import Servant.API.Sub ( type (:>) ) import Servant.API.Sub ( type (:>) )
import Servant.API.Raw ( Raw ) import Servant.API.Raw ( Raw )
import Servant.API.Alternative ( type (:<|>) ) import Servant.API.Alternative ( type (:<|>) )
@ -177,11 +175,8 @@ type family IsElem endpoint api :: Constraint where
IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParam x y :> sb) = IsElem sa sb
IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb
IsElem sa (QueryFlag x :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb
IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct' IsElem (Verb m s ct typ) (Verb m s ct' typ)
IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct' = IsSubList ct ct'
IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct'
IsElem (Patch ct typ) (Patch ct' typ) = IsSubList ct ct'
IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'
IsElem e e = () IsElem e e = ()
IsElem e a = IsElem' e a IsElem e a = IsElem' e a
@ -303,24 +298,8 @@ instance HasLink sub => HasLink (Header sym a :> sub) where
toLink _ = toLink (Proxy :: Proxy sub) toLink _ = toLink (Proxy :: Proxy sub)
-- Verb (terminal) instances -- Verb (terminal) instances
instance HasLink (Get y r) where instance HasLink (Verb m s ct a) where
type MkLink (Get y r) = URI type MkLink (Verb m s ct a) = URI
toLink _ = linkURI
instance HasLink (Post y r) where
type MkLink (Post y r) = URI
toLink _ = linkURI
instance HasLink (Put y r) where
type MkLink (Put y r) = URI
toLink _ = linkURI
instance HasLink (Patch y r) where
type MkLink (Patch y r) = URI
toLink _ = linkURI
instance HasLink (Delete y r) where
type MkLink (Delete y r) = URI
toLink _ = linkURI toLink _ = linkURI
instance HasLink Raw where instance HasLink Raw where