Merge pull request #276 from haskell-servant/jkarni/emptyWithHeaders
Consolidate verbs
This commit is contained in:
commit
357cc839b6
30 changed files with 639 additions and 1017 deletions
|
@ -4,6 +4,7 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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',
|
||||
|
@ -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',
|
||||
|
@ -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).
|
||||
-}
|
||||
|
|
|
@ -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"
|
||||
|
@ -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
|
||||
|
||||
catchConnectionError :: IO a -> IO (Either ServantError a)
|
||||
catchConnectionError action =
|
||||
|
|
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
)
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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,
|
||||
HasClient api, Client api ~ ExceptT ServantError IO ()) =>
|
||||
Proxy api -> WrappedApi
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -36,7 +36,7 @@ import Data.Monoid
|
|||
import Data.Ord (comparing)
|
||||
import Data.Proxy (Proxy(Proxy))
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import Data.Text (Text, unpack)
|
||||
import GHC.Exts (Constraint)
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits
|
||||
|
@ -49,21 +49,6 @@ import qualified Data.Text as T
|
|||
import qualified Network.HTTP.Media as M
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
|
||||
-- | Supported HTTP request methods
|
||||
data Method = DocDELETE -- ^ the DELETE method
|
||||
| DocGET -- ^ the GET method
|
||||
| DocPOST -- ^ the POST method
|
||||
| DocPUT -- ^ the PUT method
|
||||
deriving (Eq, Ord, Generic)
|
||||
|
||||
instance Show Method where
|
||||
show DocGET = "GET"
|
||||
show DocPOST = "POST"
|
||||
show DocDELETE = "DELETE"
|
||||
show DocPUT = "PUT"
|
||||
|
||||
instance Hashable Method
|
||||
|
||||
-- | An 'Endpoint' type that holds the 'path' and the 'method'.
|
||||
--
|
||||
-- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint'
|
||||
|
@ -75,12 +60,12 @@ instance Hashable Method
|
|||
-- GET /
|
||||
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
|
||||
-- GET /foo
|
||||
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'
|
||||
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
|
||||
-- POST /foo
|
||||
-- @
|
||||
data Endpoint = Endpoint
|
||||
{ _path :: [String] -- type collected
|
||||
, _method :: Method -- type collected
|
||||
{ _path :: [String] -- type collected
|
||||
, _method :: HTTP.Method -- type collected
|
||||
} deriving (Eq, Ord, Generic)
|
||||
|
||||
instance Show Endpoint where
|
||||
|
@ -94,7 +79,7 @@ showPath :: [String] -> String
|
|||
showPath [] = "/"
|
||||
showPath ps = concatMap ('/' :) ps
|
||||
|
||||
-- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET'
|
||||
-- | An 'Endpoint' whose path is `"/"` and whose method is @GET@
|
||||
--
|
||||
-- Here's how you can modify it:
|
||||
--
|
||||
|
@ -103,11 +88,11 @@ showPath ps = concatMap ('/' :) ps
|
|||
-- GET /
|
||||
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"]
|
||||
-- GET /foo
|
||||
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST'
|
||||
-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost'
|
||||
-- POST /foo
|
||||
-- @
|
||||
defEndpoint :: Endpoint
|
||||
defEndpoint = Endpoint [] DocGET
|
||||
defEndpoint = Endpoint [] HTTP.methodGet
|
||||
|
||||
instance Hashable Endpoint
|
||||
|
||||
|
@ -476,8 +461,8 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
|
|||
|
||||
-- | Synthesise a sample value of a type, encoded in the specified media types.
|
||||
sampleByteString
|
||||
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
|
||||
=> Proxy ctypes
|
||||
:: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
|
||||
=> Proxy (ct ': cts)
|
||||
-> Proxy a
|
||||
-> [(M.MediaType, ByteString)]
|
||||
sampleByteString ctypes@Proxy Proxy =
|
||||
|
@ -486,8 +471,8 @@ sampleByteString ctypes@Proxy Proxy =
|
|||
-- | Synthesise a list of sample values of a particular type, encoded in the
|
||||
-- specified media types.
|
||||
sampleByteStrings
|
||||
:: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a)
|
||||
=> Proxy ctypes
|
||||
:: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a)
|
||||
=> Proxy (ct ': cts)
|
||||
-> Proxy a
|
||||
-> [(Text, M.MediaType, ByteString)]
|
||||
sampleByteStrings ctypes@Proxy Proxy =
|
||||
|
@ -689,124 +674,37 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
|
|||
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
|
||||
=> HasDocs (Delete cts a) where
|
||||
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
|
||||
, ReflectMethod method)
|
||||
=> HasDocs (Verb method status (ct ': cts) a) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where endpoint' = endpoint & method .~ DocDELETE
|
||||
where endpoint' = endpoint & method .~ method'
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ allMime t
|
||||
t = Proxy :: Proxy cts
|
||||
& response.respStatus .~ status
|
||||
t = Proxy :: Proxy (ct ': cts)
|
||||
method' = reflectMethod (Proxy :: Proxy method)
|
||||
status = fromInteger $ natVal (Proxy :: Proxy status)
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance OVERLAPPING_
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a
|
||||
, AllHeaderSamples ls , GetHeaders (HList ls) )
|
||||
=> HasDocs (Delete cts (Headers ls a)) where
|
||||
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
|
||||
, ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
|
||||
=> HasDocs (Verb method status (ct ': cts) (Headers ls a)) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
|
||||
endpoint' = endpoint & method .~ DocDELETE
|
||||
where endpoint' = endpoint & method .~ method'
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respStatus .~ status
|
||||
& response.respHeaders .~ hdrs
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
|
||||
=> HasDocs (Get cts a) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where endpoint' = endpoint & method .~ DocGET
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ allMime t
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance OVERLAPPING_
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a
|
||||
, AllHeaderSamples ls , GetHeaders (HList ls) )
|
||||
=> HasDocs (Get cts (Headers ls a)) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
|
||||
endpoint' = endpoint & method .~ DocGET
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respHeaders .~ hdrs
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance (KnownSymbol sym, HasDocs sublayout)
|
||||
=> HasDocs (Header sym a :> sublayout) where
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor sublayoutP (endpoint, action')
|
||||
|
||||
where sublayoutP = Proxy :: Proxy sublayout
|
||||
action' = over headers (|> headername) action
|
||||
headername = pack $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
|
||||
=> HasDocs (Post cts a) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where endpoint' = endpoint & method .~ DocPOST
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respStatus .~ 201
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance OVERLAPPING_
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a
|
||||
, AllHeaderSamples ls , GetHeaders (HList ls) )
|
||||
=> HasDocs (Post cts (Headers ls a)) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
|
||||
endpoint' = endpoint & method .~ DocPOST
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respStatus .~ 201
|
||||
& response.respHeaders .~ hdrs
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
|
||||
=> HasDocs (Put cts a) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where endpoint' = endpoint & method .~ DocPUT
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respStatus .~ 200
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance OVERLAPPING_
|
||||
( ToSample a, IsNonEmpty cts, AllMimeRender cts a,
|
||||
AllHeaderSamples ls , GetHeaders (HList ls) )
|
||||
=> HasDocs (Put cts (Headers ls a)) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
|
||||
endpoint' = endpoint & method .~ DocPUT
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respStatus .~ 200
|
||||
& response.respHeaders .~ hdrs
|
||||
t = Proxy :: Proxy cts
|
||||
t = Proxy :: Proxy (ct ': cts)
|
||||
hdrs = allHeaderToSample (Proxy :: Proxy ls)
|
||||
method' = reflectMethod (Proxy :: Proxy method)
|
||||
status = fromInteger $ natVal (Proxy :: Proxy status)
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout)
|
||||
|
@ -849,8 +747,8 @@ instance HasDocs Raw where
|
|||
-- example data. However, there's no reason to believe that the instances of
|
||||
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
|
||||
-- both are even defined) for any particular type.
|
||||
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
|
||||
=> HasDocs (ReqBody cts a :> sublayout) where
|
||||
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout)
|
||||
=> HasDocs (ReqBody (ct ': cts) a :> sublayout) where
|
||||
|
||||
docsFor Proxy (endpoint, action) =
|
||||
docsFor sublayoutP (endpoint, action')
|
||||
|
@ -858,7 +756,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
|
|||
where sublayoutP = Proxy :: Proxy sublayout
|
||||
action' = action & rqbody .~ sampleByteString t p
|
||||
& rqtypes .~ allMime t
|
||||
t = Proxy :: Proxy cts
|
||||
t = Proxy :: Proxy (ct ': cts)
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where
|
||||
|
|
|
@ -71,7 +71,6 @@ spec = describe "Servant.Docs" $ do
|
|||
|
||||
it "mentions status codes" $ do
|
||||
md `shouldContain` "Status code 200"
|
||||
md `shouldContain` "Status code 201"
|
||||
|
||||
it "mentions methods" $ do
|
||||
md `shouldContain` "POST"
|
||||
|
|
|
@ -27,10 +27,11 @@ source-repository head
|
|||
|
||||
library
|
||||
exposed-modules: Servant.Foreign, Servant.Foreign.Internal
|
||||
build-depends: base == 4.*
|
||||
, lens == 4.*
|
||||
, servant == 0.5.*
|
||||
, text >= 1.2 && < 1.3
|
||||
build-depends: base == 4.*
|
||||
, lens == 4.*
|
||||
, servant == 0.5.*
|
||||
, text >= 1.2 && < 1.3
|
||||
, http-types
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
|
@ -41,6 +42,7 @@ test-suite spec
|
|||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
ghc-options: -Wall
|
||||
include-dirs: include
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Servant.ForeignSpec
|
||||
|
|
|
@ -13,18 +13,21 @@
|
|||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
|
||||
-- | Generalizes all the data needed to make code generation work with
|
||||
-- arbitrary programming languages.
|
||||
module Servant.Foreign.Internal where
|
||||
|
||||
import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
|
||||
import qualified Data.Char as C
|
||||
import Control.Lens (makeLenses, (%~), (&), (.~), (<>~))
|
||||
import qualified Data.Char as C
|
||||
import Data.Proxy
|
||||
import Data.Text
|
||||
import GHC.Exts (Constraint)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import GHC.Exts (Constraint)
|
||||
import GHC.TypeLits
|
||||
import Prelude hiding (concat)
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Prelude hiding (concat)
|
||||
import Servant.API
|
||||
|
||||
-- | Function name builder that simply concat each part together
|
||||
|
@ -86,11 +89,10 @@ defUrl :: Url
|
|||
defUrl = Url [] []
|
||||
|
||||
type FunctionName = [Text]
|
||||
type Method = Text
|
||||
|
||||
data Req = Req
|
||||
{ _reqUrl :: Url
|
||||
, _reqMethod :: Method
|
||||
, _reqMethod :: HTTP.Method
|
||||
, _reqHeaders :: [HeaderArg]
|
||||
, _reqBody :: Maybe ForeignType
|
||||
, _reqReturnType :: ForeignType
|
||||
|
@ -185,27 +187,18 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
|
|||
str = pack . symbolVal $ (Proxy :: Proxy sym)
|
||||
arg = (str, typeFor lang (Proxy :: Proxy a))
|
||||
|
||||
instance (Elem JSON list, HasForeignType lang a)
|
||||
=> HasForeign lang (Delete list a) where
|
||||
type Foreign (Delete list a) = Req
|
||||
instance (Elem JSON list, HasForeignType lang a, ReflectMethod method)
|
||||
=> HasForeign lang (Verb method status list a) where
|
||||
type Foreign (Verb method status list a) = Req
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
req & funcName %~ ("delete" :)
|
||||
& reqMethod .~ "DELETE"
|
||||
req & funcName %~ (methodLC :)
|
||||
& reqMethod .~ method
|
||||
& reqReturnType .~ retType
|
||||
where
|
||||
retType = typeFor lang (Proxy :: Proxy a)
|
||||
|
||||
instance (Elem JSON list, HasForeignType lang a)
|
||||
=> HasForeign lang (Get list a) where
|
||||
type Foreign (Get list a) = Req
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
req & funcName %~ ("get" :)
|
||||
& reqMethod .~ "GET"
|
||||
& reqReturnType .~ retType
|
||||
where
|
||||
retType = typeFor lang (Proxy :: Proxy a)
|
||||
retType = typeFor lang (Proxy :: Proxy a)
|
||||
method = reflectMethod (Proxy :: Proxy method)
|
||||
methodLC = toLower $ decodeUtf8 method
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
|
||||
=> HasForeign lang (Header sym a :> sublayout) where
|
||||
|
@ -220,28 +213,6 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
|
|||
arg = (hname, typeFor lang (Proxy :: Proxy a))
|
||||
subP = Proxy :: Proxy sublayout
|
||||
|
||||
instance (Elem JSON list, HasForeignType lang a)
|
||||
=> HasForeign lang (Post list a) where
|
||||
type Foreign (Post list a) = Req
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
req & funcName %~ ("post" :)
|
||||
& reqMethod .~ "POST"
|
||||
& reqReturnType .~ retType
|
||||
where
|
||||
retType = typeFor lang (Proxy :: Proxy a)
|
||||
|
||||
instance (Elem JSON list, HasForeignType lang a)
|
||||
=> HasForeign lang (Put list a) where
|
||||
type Foreign (Put list a) = Req
|
||||
|
||||
foreignFor lang Proxy req =
|
||||
req & funcName %~ ("put" :)
|
||||
& reqMethod .~ "PUT"
|
||||
& reqReturnType .~ retType
|
||||
where
|
||||
retType = typeFor lang (Proxy :: Proxy a)
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
|
||||
=> HasForeign lang (QueryParam sym a :> sublayout) where
|
||||
type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout
|
||||
|
@ -279,10 +250,10 @@ instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang subl
|
|||
arg = (str, typeFor lang (Proxy :: Proxy a))
|
||||
|
||||
instance HasForeign lang Raw where
|
||||
type Foreign Raw = Method -> Req
|
||||
type Foreign Raw = HTTP.Method -> Req
|
||||
|
||||
foreignFor _ Proxy req method =
|
||||
req & funcName %~ ((toLower method) :)
|
||||
req & funcName %~ ((toLower $ decodeUtf8 method) :)
|
||||
& reqMethod .~ method
|
||||
|
||||
instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout)
|
||||
|
@ -346,4 +317,3 @@ instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> res
|
|||
-- describing one endpoint from your API type.
|
||||
listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req]
|
||||
listFromAPI lang p = generateList (foreignFor lang p defReq)
|
||||
|
||||
|
|
|
@ -7,9 +7,8 @@
|
|||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
#endif
|
||||
|
||||
#include "overlapping-compat.h"
|
||||
|
||||
module Servant.ForeignSpec where
|
||||
|
||||
|
@ -41,9 +40,9 @@ instance HasForeignType LangX Int where
|
|||
typeFor _ _ = "intX"
|
||||
instance HasForeignType LangX Bool where
|
||||
typeFor _ _ = "boolX"
|
||||
instance {-# Overlapping #-} HasForeignType LangX String where
|
||||
instance OVERLAPPING_ HasForeignType LangX String where
|
||||
typeFor _ _ = "stringX"
|
||||
instance {-# Overlappable #-} HasForeignType LangX a => HasForeignType LangX [a] where
|
||||
instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where
|
||||
typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a)
|
||||
|
||||
type TestApi
|
||||
|
|
|
@ -6,6 +6,7 @@ import Data.Maybe (isJust)
|
|||
import Data.Monoid
|
||||
import qualified Data.Text as T
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Servant.Foreign
|
||||
import Servant.JS.Internal
|
||||
|
||||
|
@ -68,7 +69,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
|
|||
<> " { url: " <> url <> "\n"
|
||||
<> dataBody
|
||||
<> reqheaders
|
||||
<> " , method: '" <> method <> "'\n"
|
||||
<> " , method: '" <> decodeUtf8 method <> "'\n"
|
||||
<> " });\n"
|
||||
<> "}\n"
|
||||
|
||||
|
|
|
@ -5,6 +5,7 @@ import Control.Lens
|
|||
import Data.Maybe (isJust)
|
||||
import Data.Monoid
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import qualified Data.Text as T
|
||||
import Servant.Foreign
|
||||
import Servant.JS.Internal
|
||||
|
@ -117,7 +118,7 @@ generateAxiosJSWith aopts opts req = "\n" <>
|
|||
|
||||
fname = namespace <> (functionNameBuilder opts $ req ^. funcName)
|
||||
|
||||
method = T.toLower $ req ^. reqMethod
|
||||
method = T.toLower . decodeUtf8 $ req ^. reqMethod
|
||||
url = if url' == "'" then "'/'" else url'
|
||||
url' = "'"
|
||||
<> urlPrefix opts
|
||||
|
|
|
@ -6,6 +6,7 @@ import Data.Maybe (isJust)
|
|||
import Data.Monoid
|
||||
import qualified Data.Text as T
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Servant.Foreign
|
||||
import Servant.JS.Internal
|
||||
|
||||
|
@ -35,7 +36,7 @@ generateJQueryJSWith opts req = "\n" <>
|
|||
<> dataBody
|
||||
<> reqheaders
|
||||
<> " , error: " <> onError <> "\n"
|
||||
<> " , type: '" <> method <> "'\n"
|
||||
<> " , type: '" <> decodeUtf8 method <> "'\n"
|
||||
<> " });\n"
|
||||
<> "}\n"
|
||||
|
||||
|
|
|
@ -4,6 +4,7 @@ module Servant.JS.Vanilla where
|
|||
import Control.Lens
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import qualified Data.Text as T
|
||||
import Data.Monoid
|
||||
import Servant.Foreign
|
||||
|
@ -31,7 +32,7 @@ generateVanillaJSWith opts req = "\n" <>
|
|||
fname <> " = function(" <> argsStr <> ")\n"
|
||||
<> "{\n"
|
||||
<> " var xhr = new XMLHttpRequest();\n"
|
||||
<> " xhr.open('" <> method <> "', " <> url <> ", true);\n"
|
||||
<> " xhr.open('" <> decodeUtf8 method <> "', " <> url <> ", true);\n"
|
||||
<> reqheaders
|
||||
<> " xhr.setRequestHeader(\"Accept\",\"application/json\");\n"
|
||||
<> (if isJust (req ^. reqBody) then " xhr.setRequestHeader(\"Content-Type\",\"application/json\");\n" else "")
|
||||
|
|
|
@ -139,19 +139,8 @@ instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where
|
|||
instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where
|
||||
mock _ = \_ -> mock (Proxy :: Proxy rest)
|
||||
|
||||
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Delete ctypes a) where
|
||||
mock _ = mockArbitrary
|
||||
|
||||
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Get ctypes a) where
|
||||
mock _ = mockArbitrary
|
||||
|
||||
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Patch ctypes a) where
|
||||
mock _ = mockArbitrary
|
||||
|
||||
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Post ctypes a) where
|
||||
mock _ = mockArbitrary
|
||||
|
||||
instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Put ctypes a) where
|
||||
instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a)
|
||||
=> HasMock (Verb method status ctypes a) where
|
||||
mock _ = mockArbitrary
|
||||
|
||||
instance HasMock Raw where
|
||||
|
|
|
@ -21,26 +21,33 @@ module Servant.Server.Internal
|
|||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (ConvertibleStrings, cs, (<>))
|
||||
import Data.Text (Text)
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs, (<>))
|
||||
import Data.Text (Text)
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Network.HTTP.Types hiding (Header, ResponseHeaders)
|
||||
import Network.Socket (SockAddr)
|
||||
import Network.Wai (Application, lazyRequestBody,
|
||||
rawQueryString, requestHeaders,
|
||||
requestMethod, responseLBS, remoteHost,
|
||||
isSecure, vault, httpVersion, Response,
|
||||
Request, pathInfo)
|
||||
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
|
||||
symbolVal)
|
||||
import Network.HTTP.Types hiding (Header, ResponseHeaders)
|
||||
import Network.Socket (SockAddr)
|
||||
import Network.Wai (Application, Request, Response,
|
||||
httpVersion, isSecure,
|
||||
lazyRequestBody, pathInfo,
|
||||
rawQueryString, remoteHost,
|
||||
requestHeaders, requestMethod,
|
||||
responseLBS, vault)
|
||||
import Web.HttpApiData (FromHttpApiData)
|
||||
import Web.HttpApiData.Internal (parseHeaderMaybe,
|
||||
parseQueryParamMaybe,
|
||||
parseUrlPieceMaybe)
|
||||
|
||||
import Servant.API ((:<|>) (..), (:>), Capture,
|
||||
Delete, Get, Header,
|
||||
IsSecure(..), Patch, Post, Put,
|
||||
Verb, ReflectMethod(reflectMethod),
|
||||
IsSecure(..), Header,
|
||||
QueryFlag, QueryParam, QueryParams,
|
||||
Raw, RemoteHost, ReqBody, Vault)
|
||||
import Servant.API.ContentTypes (AcceptHeader (..),
|
||||
|
@ -55,8 +62,6 @@ import Servant.Server.Internal.Router
|
|||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
||||
import Web.HttpApiData (FromHttpApiData)
|
||||
import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe)
|
||||
|
||||
class HasServer layout where
|
||||
type ServerT layout (m :: * -> *) :: *
|
||||
|
@ -129,8 +134,7 @@ allowedMethodHead method request = method == methodGet && requestMethod request
|
|||
allowedMethod :: Method -> Request -> Bool
|
||||
allowedMethod method request = allowedMethodHead method request || requestMethod request == method
|
||||
|
||||
processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
|
||||
=> Maybe (a, BL.ByteString) -> Status -> Method
|
||||
processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method
|
||||
-> Maybe [(HeaderName, B.ByteString)]
|
||||
-> Request -> RouteResult Response
|
||||
processMethodRouter handleA status method headers request = case handleA of
|
||||
|
@ -160,7 +164,7 @@ methodRouter method proxy status action = LeafRouter route'
|
|||
| pathIsEmpty request =
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
in runAction (action `addMethodCheck` methodCheck method request
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
) respond $ \ output -> do
|
||||
let handleA = handleAcceptH proxy (AcceptHeader accH) output
|
||||
processMethodRouter handleA status method Nothing request
|
||||
|
@ -176,95 +180,33 @@ methodRouterHeaders method proxy status action = LeafRouter route'
|
|||
| pathIsEmpty request =
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
in runAction (action `addMethodCheck` methodCheck method request
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
) respond $ \ output -> do
|
||||
let headers = getHeaders output
|
||||
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
|
||||
processMethodRouter handleA status method (Just headers) request
|
||||
| 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_
|
||||
( AllCTRender ctypes a
|
||||
) => HasServer (Delete ctypes a) where
|
||||
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
||||
) => 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_
|
||||
HasServer (Delete ctypes ()) where
|
||||
( 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
|
||||
|
||||
-- Add response headers
|
||||
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
|
||||
route Proxy = methodRouterHeaders method (Proxy :: Proxy ctypes) status
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
||||
|
||||
-- | If you use 'Header' in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
|
@ -297,113 +239,6 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
|
|||
in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
|
||||
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,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
-- that takes an argument of type @'Maybe' 'Text'@.
|
||||
|
|
|
@ -162,7 +162,7 @@ errorRetrySpec = describe "Handler search"
|
|||
|
||||
it "should continue when URLs don't match" $ do
|
||||
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
|
||||
request methodGet "a" [jsonCT, jsonAccept] jsonBody
|
||||
|
|
|
@ -52,7 +52,7 @@ enterSpec = describe "Enter" $ do
|
|||
|
||||
it "allows running arbitrary monads" $ do
|
||||
get "int" `shouldRespondWith` "1797"
|
||||
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 }
|
||||
post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 }
|
||||
|
||||
with (return (serve combinedAPI combinedReaderServer)) $ do
|
||||
it "allows combnation of enters" $ do
|
||||
|
|
|
@ -3,8 +3,10 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
|
@ -13,7 +15,7 @@ module Servant.ServerSpec where
|
|||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad (forM_, when)
|
||||
import Control.Monad (forM_, when, unless)
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE)
|
||||
import Data.Aeson (FromJSON, ToJSON, decode', encode)
|
||||
import Data.ByteString.Conversion ()
|
||||
|
@ -23,82 +25,144 @@ import Data.String (fromString)
|
|||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Types (hAccept, hContentType,
|
||||
methodDelete, methodGet, methodHead,
|
||||
methodPatch, methodPost, methodPut,
|
||||
ok200, parseQuery, Status(..))
|
||||
import Network.HTTP.Types (Status (..), hAccept, hContentType,
|
||||
methodDelete, methodGet,
|
||||
methodHead, methodPatch,
|
||||
methodPost, methodPut, ok200,
|
||||
parseQuery)
|
||||
import Network.Wai (Application, Request, pathInfo,
|
||||
queryString, rawQueryString,
|
||||
responseLBS, responseBuilder)
|
||||
import Network.Wai.Internal (Response(ResponseBuilder))
|
||||
responseBuilder, responseLBS)
|
||||
import Network.Wai.Internal (Response (ResponseBuilder))
|
||||
import Network.Wai.Test (defaultRequest, request,
|
||||
runSession, simpleBody)
|
||||
runSession, simpleBody,
|
||||
simpleHeaders, simpleStatus)
|
||||
import Servant.API ((:<|>) (..), (:>), Capture, Delete,
|
||||
Get, Header (..), Headers,
|
||||
HttpVersion, IsSecure (..), JSON,
|
||||
Patch, PlainText, Post, Put,
|
||||
Get, Header (..),
|
||||
Headers, HttpVersion,
|
||||
IsSecure (..), JSON,
|
||||
NoContent (..), Patch, PlainText,
|
||||
Post, Put,
|
||||
QueryFlag, QueryParam, QueryParams,
|
||||
Raw, RemoteHost, ReqBody,
|
||||
addHeader)
|
||||
import Servant.Server (Server, serve, ServantErr(..), err404)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
StdMethod (..), Verb, addHeader)
|
||||
import Servant.Server (ServantErr (..), Server, err404,
|
||||
serve)
|
||||
import Test.Hspec (Spec, context, describe, it,
|
||||
shouldBe, shouldContain)
|
||||
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
||||
matchStatus, post, request,
|
||||
matchStatus, request,
|
||||
shouldRespondWith, with, (<:>))
|
||||
import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..))
|
||||
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
(toApplication, RouteResult(..))
|
||||
import Servant.Server.Internal.Router
|
||||
(tweakResponse, runRouter,
|
||||
Router, Router'(LeafRouter))
|
||||
|
||||
|
||||
-- * test data types
|
||||
|
||||
data Person = Person {
|
||||
name :: String,
|
||||
age :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Person
|
||||
instance FromJSON Person
|
||||
|
||||
alice :: Person
|
||||
alice = Person "Alice" 42
|
||||
|
||||
data Animal = Animal {
|
||||
species :: String,
|
||||
numberOfLegs :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Animal
|
||||
instance FromJSON Animal
|
||||
|
||||
jerry :: Animal
|
||||
jerry = Animal "Mouse" 4
|
||||
|
||||
tweety :: Animal
|
||||
tweety = Animal "Bird" 2
|
||||
|
||||
|
||||
-- * specs
|
||||
-- * Specs
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
verbSpec
|
||||
captureSpec
|
||||
getSpec
|
||||
headSpec
|
||||
postSpec
|
||||
putSpec
|
||||
patchSpec
|
||||
queryParamSpec
|
||||
reqBodySpec
|
||||
headerSpec
|
||||
rawSpec
|
||||
unionSpec
|
||||
routerSpec
|
||||
alternativeSpec
|
||||
responseHeadersSpec
|
||||
miscReqCombinatorsSpec
|
||||
routerSpec
|
||||
miscCombinatorSpec
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- * verbSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type VerbApi method status
|
||||
= Verb method status '[JSON] Person
|
||||
:<|> "noContent" :> Verb method status '[JSON] NoContent
|
||||
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
|
||||
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
|
||||
|
||||
verbSpec :: Spec
|
||||
verbSpec = describe "Servant.API.Verb" $ do
|
||||
let server :: Server (VerbApi method status)
|
||||
server = return alice
|
||||
:<|> return NoContent
|
||||
:<|> return (addHeader 5 alice)
|
||||
:<|> return (addHeader 10 NoContent)
|
||||
get200 = Proxy :: Proxy (VerbApi 'GET 200)
|
||||
post210 = Proxy :: Proxy (VerbApi 'POST 210)
|
||||
put203 = Proxy :: Proxy (VerbApi 'PUT 203)
|
||||
delete280 = Proxy :: Proxy (VerbApi 'DELETE 280)
|
||||
patch214 = Proxy :: Proxy (VerbApi 'PATCH 214)
|
||||
wrongMethod m = if m == methodPatch then methodPost else methodPatch
|
||||
test desc api method (status :: Int) = context desc $
|
||||
|
||||
with (return $ serve api server) $ do
|
||||
|
||||
-- HEAD and 214/215 need not return bodies
|
||||
unless (status `elem` [214, 215] || method == methodHead) $
|
||||
it "returns the person" $ do
|
||||
response <- Test.Hspec.Wai.request method "/" [] ""
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` status
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
||||
|
||||
it "returns no content on NoContent" $ do
|
||||
response <- Test.Hspec.Wai.request method "/noContent" [] ""
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` status
|
||||
liftIO $ simpleBody response `shouldBe` ""
|
||||
|
||||
-- HEAD should not return body
|
||||
when (method == methodHead) $
|
||||
it "HEAD returns no content body" $ do
|
||||
response <- Test.Hspec.Wai.request method "/" [] ""
|
||||
liftIO $ simpleBody response `shouldBe` ""
|
||||
|
||||
it "throws 405 on wrong method " $ do
|
||||
Test.Hspec.Wai.request (wrongMethod method) "/" [] ""
|
||||
`shouldRespondWith` 405
|
||||
|
||||
it "returns headers" $ do
|
||||
response1 <- Test.Hspec.Wai.request method "/header" [] ""
|
||||
liftIO $ statusCode (simpleStatus response1) `shouldBe` status
|
||||
liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")]
|
||||
|
||||
response2 <- Test.Hspec.Wai.request method "/header" [] ""
|
||||
liftIO $ statusCode (simpleStatus response2) `shouldBe` status
|
||||
liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
response <- Test.Hspec.Wai.request method "/headerNC/" [] ""
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` status
|
||||
|
||||
it "returns 406 if the Accept header is not supported" $ do
|
||||
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 406
|
||||
|
||||
it "responds if the Accept header is supported" $ do
|
||||
response <- Test.Hspec.Wai.request method ""
|
||||
[(hAccept, "application/json")] ""
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` status
|
||||
|
||||
it "sets the Content-Type header" $ do
|
||||
response <- Test.Hspec.Wai.request method "" [] ""
|
||||
liftIO $ simpleHeaders response `shouldContain`
|
||||
[("Content-Type", "application/json")]
|
||||
|
||||
test "GET 200" get200 methodGet 200
|
||||
test "POST 210" post210 methodPost 210
|
||||
test "PUT 203" put203 methodPut 203
|
||||
test "DELETE 280" delete280 methodDelete 280
|
||||
test "PATCH 214" patch214 methodPatch 214
|
||||
test "GET 200 with HEAD" get200 methodHead 200
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * captureSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
|
||||
captureApi :: Proxy CaptureApi
|
||||
|
@ -128,63 +192,10 @@ captureSpec = do
|
|||
it "strips the captured path snippet from pathInfo" $ do
|
||||
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
|
||||
|
||||
|
||||
type GetApi = Get '[JSON] Person
|
||||
:<|> "empty" :> Get '[] ()
|
||||
:<|> "post" :> Post '[] ()
|
||||
getApi :: Proxy GetApi
|
||||
getApi = Proxy
|
||||
|
||||
getSpec :: Spec
|
||||
getSpec = do
|
||||
describe "Servant.API.Get" $ do
|
||||
let server = return alice :<|> return () :<|> return ()
|
||||
with (return $ serve getApi server) $ do
|
||||
|
||||
it "allows to GET a Person" $ do
|
||||
response <- get "/"
|
||||
return response `shouldRespondWith` 200
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
||||
|
||||
it "throws 405 (wrong method) on POSTs" $ do
|
||||
post "/" "" `shouldRespondWith` 405
|
||||
post "/empty" "" `shouldRespondWith` 405
|
||||
|
||||
it "returns 204 if the type is '()'" $ do
|
||||
get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
|
||||
|
||||
it "returns 406 if the Accept header is not supported" $ do
|
||||
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 406
|
||||
|
||||
|
||||
headSpec :: Spec
|
||||
headSpec = do
|
||||
describe "Servant.API.Head" $ do
|
||||
let server = return alice :<|> return () :<|> return ()
|
||||
with (return $ serve getApi server) $ do
|
||||
|
||||
it "allows to GET a Person" $ do
|
||||
response <- Test.Hspec.Wai.request methodHead "/" [] ""
|
||||
return response `shouldRespondWith` 200
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person)
|
||||
|
||||
it "does not allow HEAD to POST route" $ do
|
||||
response <- Test.Hspec.Wai.request methodHead "/post" [] ""
|
||||
return response `shouldRespondWith` 405
|
||||
|
||||
it "throws 405 (wrong method) on POSTs" $ do
|
||||
post "/" "" `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
|
||||
Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 406
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * queryParamSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
|
||||
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
|
||||
|
@ -269,131 +280,41 @@ queryParamSpec = do
|
|||
name = "Alice"
|
||||
}
|
||||
|
||||
type PostApi =
|
||||
ReqBody '[JSON] Person :> Post '[JSON] Integer
|
||||
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
|
||||
:<|> "empty" :> Post '[] ()
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * reqBodySpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person
|
||||
:<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
|
||||
|
||||
postApi :: Proxy PostApi
|
||||
postApi = Proxy
|
||||
reqBodyApi :: Proxy ReqBodyApi
|
||||
reqBodyApi = Proxy
|
||||
|
||||
postSpec :: Spec
|
||||
postSpec = do
|
||||
describe "Servant.API.Post and .ReqBody" $ do
|
||||
let server = return . age :<|> return . age :<|> return ()
|
||||
with (return $ serve postApi server) $ do
|
||||
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
|
||||
, "application/json;charset=utf-8")]
|
||||
reqBodySpec :: Spec
|
||||
reqBodySpec = describe "Servant.API.ReqBody" $ do
|
||||
|
||||
it "allows to POST a Person" $ do
|
||||
post' "/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 201
|
||||
}
|
||||
let server :: Server ReqBodyApi
|
||||
server = return :<|> return . age
|
||||
mkReq method x = Test.Hspec.Wai.request method x
|
||||
[(hContentType, "application/json;charset=utf-8")]
|
||||
|
||||
it "allows alternative routes if all have request bodies" $ do
|
||||
post' "/bla" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 201
|
||||
}
|
||||
with (return $ serve reqBodyApi server) $ do
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
post' "/bla/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 201
|
||||
}
|
||||
it "passes the argument to the handler" $ do
|
||||
response <- mkReq methodPost "" (encode alice)
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
||||
|
||||
it "correctly rejects invalid request bodies with status 400" $ do
|
||||
post' "/" "some invalid body" `shouldRespondWith` 400
|
||||
it "rejects invalid request bodies with status 400" $ do
|
||||
mkReq methodPut "/blah" "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
|
||||
Test.Hspec.Wai.request methodPost "/"
|
||||
[(hContentType, "application/nonsense")] "" `shouldRespondWith` 415
|
||||
|
||||
it "responds with 415 if the request body media type is unsupported" $ do
|
||||
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
|
||||
, "application/nonsense")]
|
||||
post'' "/" "anything at all" `shouldRespondWith` 415
|
||||
|
||||
type PutApi =
|
||||
ReqBody '[JSON] Person :> Put '[JSON] Integer
|
||||
:<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
|
||||
:<|> "empty" :> Put '[] ()
|
||||
|
||||
putApi :: Proxy PutApi
|
||||
putApi = Proxy
|
||||
|
||||
putSpec :: Spec
|
||||
putSpec = do
|
||||
describe "Servant.API.Put and .ReqBody" $ do
|
||||
let server = return . age :<|> return . age :<|> return ()
|
||||
with (return $ serve putApi server) $ do
|
||||
let put' x = Test.Hspec.Wai.request methodPut x [(hContentType
|
||||
, "application/json;charset=utf-8")]
|
||||
|
||||
it "allows to put a Person" $ do
|
||||
put' "/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "allows alternative routes if all have request bodies" $ do
|
||||
put' "/bla" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
put' "/bla/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "correctly rejects invalid request bodies with status 400" $ do
|
||||
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
|
||||
let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
|
||||
, "application/nonsense")]
|
||||
put'' "/" "anything at all" `shouldRespondWith` 415
|
||||
|
||||
type PatchApi =
|
||||
ReqBody '[JSON] Person :> Patch '[JSON] Integer
|
||||
:<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer
|
||||
:<|> "empty" :> Patch '[] ()
|
||||
|
||||
patchApi :: Proxy PatchApi
|
||||
patchApi = Proxy
|
||||
|
||||
patchSpec :: Spec
|
||||
patchSpec = do
|
||||
describe "Servant.API.Patch and .ReqBody" $ do
|
||||
let server = return . age :<|> return . age :<|> return ()
|
||||
with (return $ serve patchApi server) $ do
|
||||
let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType
|
||||
, "application/json;charset=utf-8")]
|
||||
|
||||
it "allows to patch a Person" $ do
|
||||
patch' "/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "allows alternative routes if all have request bodies" $ do
|
||||
patch' "/bla" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "handles trailing '/' gracefully" $ do
|
||||
patch' "/bla/" (encode alice) `shouldRespondWith` "42"{
|
||||
matchStatus = 200
|
||||
}
|
||||
|
||||
it "correctly rejects invalid request bodies with status 400" $ do
|
||||
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
|
||||
let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
|
||||
, "application/nonsense")]
|
||||
patch'' "/" "anything at all" `shouldRespondWith` 415
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * headerSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] ()
|
||||
headerApi :: Proxy (HeaderApi a)
|
||||
|
@ -411,23 +332,30 @@ headerSpec = describe "Servant.API.Header" $ do
|
|||
expectsString Nothing = error "Expected a string"
|
||||
|
||||
with (return (serve headerApi expectsInt)) $ do
|
||||
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]
|
||||
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]
|
||||
|
||||
it "passes the header to the handler (Int)" $
|
||||
delete' "/" "" `shouldRespondWith` 204
|
||||
delete' "/" "" `shouldRespondWith` 200
|
||||
|
||||
with (return (serve headerApi expectsString)) $ do
|
||||
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]
|
||||
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]
|
||||
|
||||
it "passes the header to the handler (String)" $
|
||||
delete' "/" "" `shouldRespondWith` 204
|
||||
delete' "/" "" `shouldRespondWith` 200
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * rawSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type RawApi = "foo" :> Raw
|
||||
|
||||
rawApi :: Proxy RawApi
|
||||
rawApi = Proxy
|
||||
|
||||
rawApplication :: Show a => (Request -> a) -> Application
|
||||
rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_)
|
||||
rawApplication f request_ respond = respond $ responseLBS ok200 []
|
||||
(cs $ show $ f request_)
|
||||
|
||||
rawSpec :: Spec
|
||||
rawSpec = do
|
||||
|
@ -448,7 +376,10 @@ rawSpec = do
|
|||
liftIO $ do
|
||||
simpleBody response `shouldBe` cs (show ["bar" :: String])
|
||||
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * alternativeSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
type AlternativeApi =
|
||||
"foo" :> Get '[JSON] Person
|
||||
:<|> "bar" :> Get '[JSON] Animal
|
||||
|
@ -456,11 +387,12 @@ type AlternativeApi =
|
|||
:<|> "bar" :> Post '[JSON] Animal
|
||||
:<|> "bar" :> Put '[JSON] Animal
|
||||
:<|> "bar" :> Delete '[JSON] ()
|
||||
unionApi :: Proxy AlternativeApi
|
||||
unionApi = Proxy
|
||||
|
||||
unionServer :: Server AlternativeApi
|
||||
unionServer =
|
||||
alternativeApi :: Proxy AlternativeApi
|
||||
alternativeApi = Proxy
|
||||
|
||||
alternativeServer :: Server AlternativeApi
|
||||
alternativeServer =
|
||||
return alice
|
||||
:<|> return jerry
|
||||
:<|> return "a string"
|
||||
|
@ -468,10 +400,10 @@ unionServer =
|
|||
:<|> return jerry
|
||||
:<|> return ()
|
||||
|
||||
unionSpec :: Spec
|
||||
unionSpec = do
|
||||
alternativeSpec :: Spec
|
||||
alternativeSpec = do
|
||||
describe "Servant.API.Alternative" $ do
|
||||
with (return $ serve unionApi unionServer) $ do
|
||||
with (return $ serve alternativeApi alternativeServer) $ do
|
||||
|
||||
it "unions endpoints" $ do
|
||||
response <- get "/foo"
|
||||
|
@ -488,7 +420,10 @@ unionSpec = do
|
|||
|
||||
it "returns 404 if the path does not exist" $ do
|
||||
get "/nonexistent" `shouldRespondWith` 404
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * responseHeaderSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
type ResponseHeadersApi =
|
||||
Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
|
||||
:<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
|
||||
|
@ -505,26 +440,29 @@ responseHeadersSpec :: Spec
|
|||
responseHeadersSpec = describe "ResponseHeaders" $ do
|
||||
with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do
|
||||
|
||||
let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)]
|
||||
let methods = [methodGet, methodPost, methodPut, methodPatch]
|
||||
|
||||
it "includes the headers in the response" $
|
||||
forM_ methods $ \(method, expected) ->
|
||||
forM_ methods $ \method ->
|
||||
Test.Hspec.Wai.request method "/" [] ""
|
||||
`shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
|
||||
, matchStatus = expected
|
||||
, matchStatus = 200
|
||||
}
|
||||
|
||||
it "responds with not found for non-existent endpoints" $
|
||||
forM_ methods $ \(method,_) ->
|
||||
forM_ methods $ \method ->
|
||||
Test.Hspec.Wai.request method "blahblah" [] ""
|
||||
`shouldRespondWith` 404
|
||||
|
||||
it "returns 406 if the Accept header is not supported" $
|
||||
forM_ methods $ \(method,_) ->
|
||||
forM_ methods $ \method ->
|
||||
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 406
|
||||
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * routerSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
routerSpec :: Spec
|
||||
routerSpec = do
|
||||
describe "Servant.Server.Internal.Router" $ do
|
||||
|
@ -543,6 +481,10 @@ routerSpec = do
|
|||
it "calls f on route result" $ do
|
||||
get "" `shouldRespondWith` 202
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * miscCombinatorSpec {{{
|
||||
------------------------------------------------------------------------------
|
||||
type MiscCombinatorsAPI
|
||||
= "version" :> HttpVersion :> Get '[JSON] String
|
||||
:<|> "secure" :> IsSecure :> Get '[JSON] String
|
||||
|
@ -561,8 +503,8 @@ miscServ = versionHandler
|
|||
secureHandler NotSecure = return "not secure"
|
||||
hostHandler = return . show
|
||||
|
||||
miscReqCombinatorsSpec :: Spec
|
||||
miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $
|
||||
miscCombinatorSpec :: Spec
|
||||
miscCombinatorSpec = with (return $ serve miscApi miscServ) $
|
||||
describe "Misc. combinators for request inspection" $ do
|
||||
it "Successfully gets the HTTP version specified in the request" $
|
||||
go "/version" "\"HTTP/1.0\""
|
||||
|
@ -574,3 +516,35 @@ miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $
|
|||
go "/host" "\"0.0.0.0:0\""
|
||||
|
||||
where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Test data types {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
data Person = Person {
|
||||
name :: String,
|
||||
age :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Person
|
||||
instance FromJSON Person
|
||||
|
||||
alice :: Person
|
||||
alice = Person "Alice" 42
|
||||
|
||||
data Animal = Animal {
|
||||
species :: String,
|
||||
numberOfLegs :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Animal
|
||||
instance FromJSON Animal
|
||||
|
||||
jerry :: Animal
|
||||
jerry = Animal "Mouse" 4
|
||||
|
||||
tweety :: Animal
|
||||
tweety = Animal "Bird" 2
|
||||
-- }}}
|
||||
|
|
|
@ -15,12 +15,7 @@ import System.IO.Temp (withSystemTempDirectory)
|
|||
import Test.Hspec (Spec, around_, describe, it)
|
||||
import Test.Hspec.Wai (get, shouldRespondWith, with)
|
||||
|
||||
import Servant.API (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.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
|
||||
import Servant.Server (Server, serve)
|
||||
import Servant.ServerSpec (Person (Person))
|
||||
import Servant.Utils.StaticFiles (serveDirectory)
|
||||
|
|
|
@ -7,6 +7,8 @@ HEAD
|
|||
* Use `http-api-data` instead of `Servant.Common.Text`
|
||||
* Remove matrix params.
|
||||
* Add PlainText String MimeRender and MimeUnrender instances.
|
||||
* Add new `Verbs` combinator, and make all existing and new verb combinators
|
||||
type synonyms of it.
|
||||
|
||||
0.4.2
|
||||
-----
|
||||
|
|
|
@ -29,14 +29,9 @@ library
|
|||
Servant.API.Alternative
|
||||
Servant.API.Capture
|
||||
Servant.API.ContentTypes
|
||||
Servant.API.Delete
|
||||
Servant.API.Get
|
||||
Servant.API.Header
|
||||
Servant.API.HttpVersion
|
||||
Servant.API.IsSecure
|
||||
Servant.API.Patch
|
||||
Servant.API.Post
|
||||
Servant.API.Put
|
||||
Servant.API.QueryParam
|
||||
Servant.API.Raw
|
||||
Servant.API.RemoteHost
|
||||
|
@ -44,6 +39,7 @@ library
|
|||
Servant.API.ResponseHeaders
|
||||
Servant.API.Sub
|
||||
Servant.API.Vault
|
||||
Servant.API.Verbs
|
||||
Servant.Utils.Links
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
|
|
|
@ -25,16 +25,7 @@ module Servant.API (
|
|||
-- | Access the location for arbitrary data to be shared by applications and middleware
|
||||
|
||||
-- * Actual endpoints, distinguished by HTTP method
|
||||
module Servant.API.Get,
|
||||
-- | @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
|
||||
module Servant.API.Verbs,
|
||||
|
||||
-- * Content Types
|
||||
module Servant.API.ContentTypes,
|
||||
|
@ -61,17 +52,12 @@ import Servant.API.Alternative ((:<|>) (..))
|
|||
import Servant.API.Capture (Capture)
|
||||
import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
|
||||
FromFormUrlEncoded (..), JSON,
|
||||
MimeRender (..),
|
||||
MimeRender (..), NoContent (NoContent),
|
||||
MimeUnrender (..), OctetStream,
|
||||
PlainText, ToFormUrlEncoded (..))
|
||||
import Servant.API.Delete (Delete)
|
||||
import Servant.API.Get (Get)
|
||||
import Servant.API.Header (Header (..))
|
||||
import Servant.API.HttpVersion (HttpVersion (..))
|
||||
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,
|
||||
QueryParams)
|
||||
import Servant.API.Raw (Raw)
|
||||
|
@ -84,7 +70,25 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader),
|
|||
getHeadersHList, getResponse)
|
||||
import Servant.API.Sub ((:>))
|
||||
import Servant.API.Vault (Vault)
|
||||
import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
|
||||
import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted,
|
||||
DeleteNoContent,
|
||||
DeleteNonAuthoritative, Get,
|
||||
GetAccepted, GetNoContent,
|
||||
GetNonAuthoritative,
|
||||
GetPartialContent,
|
||||
GetResetContent,
|
||||
Patch,
|
||||
PatchAccepted, PatchNoContent,
|
||||
PatchNoContent,
|
||||
PatchNonAuthoritative, Post,
|
||||
PostAccepted, PostNoContent,
|
||||
PostNonAuthoritative,
|
||||
PostResetContent, Put,
|
||||
PutAccepted, PutNoContent,
|
||||
PutNoContent, PutNonAuthoritative,
|
||||
ReflectMethod (reflectMethod),
|
||||
Verb, StdMethod(..))
|
||||
import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
|
||||
URI (..), safeLink)
|
||||
|
||||
import Web.HttpApiData (FromHttpApiData (..),
|
||||
ToHttpApiData (..))
|
||||
|
|
|
@ -2,6 +2,7 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
@ -12,6 +13,8 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
|
||||
#include "overlapping-compat.h"
|
||||
|
||||
-- | A collection of basic Content-Types (also known as Internet Media
|
||||
-- Types, or MIME types). Additionally, this module provides classes that
|
||||
-- encapsulate how to serialize or deserialize values to or from
|
||||
|
@ -19,7 +22,7 @@
|
|||
--
|
||||
-- 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@
|
||||
-- or @text/plain;charset-utf8@, and returns data in either one of those
|
||||
|
@ -53,6 +56,9 @@ module Servant.API.ContentTypes
|
|||
, MimeRender(..)
|
||||
, MimeUnrender(..)
|
||||
|
||||
-- * NoContent
|
||||
, NoContent(..)
|
||||
|
||||
-- * Internal
|
||||
, AcceptHeader(..)
|
||||
, AllCTRender(..)
|
||||
|
@ -62,7 +68,6 @@ module Servant.API.ContentTypes
|
|||
, AllMimeUnrender(..)
|
||||
, FromFormUrlEncoded(..)
|
||||
, ToFormUrlEncoded(..)
|
||||
, IsNonEmpty
|
||||
, eitherDecodeLenient
|
||||
, canHandleAcceptH
|
||||
) where
|
||||
|
@ -72,8 +77,7 @@ import Control.Applicative ((*>), (<*))
|
|||
#endif
|
||||
import Control.Arrow (left)
|
||||
import Control.Monad
|
||||
import Data.Aeson (FromJSON, ToJSON, encode,
|
||||
parseJSON)
|
||||
import Data.Aeson (FromJSON(..), ToJSON(..), encode)
|
||||
import Data.Aeson.Parser (value)
|
||||
import Data.Aeson.Types (parseEither)
|
||||
import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,
|
||||
|
@ -91,7 +95,7 @@ import qualified Data.Text.Encoding as TextS
|
|||
import qualified Data.Text.Lazy as TextL
|
||||
import qualified Data.Text.Lazy.Encoding as TextL
|
||||
import Data.Typeable
|
||||
import GHC.Exts (Constraint)
|
||||
import GHC.Generics (Generic)
|
||||
import qualified Network.HTTP.Media as M
|
||||
import Network.URI (escapeURIString,
|
||||
isUnreserved, unEscapeString)
|
||||
|
@ -137,7 +141,7 @@ instance Accept OctetStream where
|
|||
contentType _ = "application" M.// "octet-stream"
|
||||
|
||||
newtype AcceptHeader = AcceptHeader BS.ByteString
|
||||
deriving (Eq, Show)
|
||||
deriving (Eq, Show, Read, Typeable, Generic)
|
||||
|
||||
-- * Render (serializing)
|
||||
|
||||
|
@ -159,19 +163,19 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
|
|||
class Accept ctype => MimeRender ctype a where
|
||||
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
|
||||
-- Content-Type and response (serialization of @a@ into the appropriate
|
||||
-- mimetype).
|
||||
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
|
||||
|
||||
instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
|
||||
instance OVERLAPPABLE_
|
||||
(AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where
|
||||
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
|
||||
where pctyps = Proxy :: Proxy ctyps
|
||||
where pctyps = Proxy :: Proxy (ct ': cts)
|
||||
amrs = allMimeRender pctyps val
|
||||
lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * Unrender
|
||||
|
||||
|
@ -199,14 +203,13 @@ instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
|
|||
class Accept ctype => MimeUnrender ctype a where
|
||||
mimeUnrender :: Proxy ctype -> ByteString -> Either String a
|
||||
|
||||
class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where
|
||||
class AllCTUnrender (list :: [*]) a where
|
||||
handleCTypeH :: Proxy list
|
||||
-> ByteString -- Content-Type header
|
||||
-> ByteString -- Request body
|
||||
-> Maybe (Either String a)
|
||||
|
||||
instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
|
||||
) => AllCTUnrender ctyps a where
|
||||
instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
|
||||
handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
|
||||
where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
|
||||
|
||||
|
@ -235,11 +238,12 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where
|
|||
-> a -- value to serialize
|
||||
-> [(M.MediaType, ByteString)] -- content-types/response pairs
|
||||
|
||||
instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
|
||||
instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
|
||||
allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)]
|
||||
where pctyp = Proxy :: Proxy ctyp
|
||||
|
||||
instance ( MimeRender ctyp a
|
||||
instance OVERLAPPABLE_
|
||||
( MimeRender ctyp a
|
||||
, AllMimeRender (ctyp' ': ctyps) a
|
||||
) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
|
||||
allMimeRender _ a = (contentType pctyp, mimeRender pctyp a)
|
||||
|
@ -248,8 +252,17 @@ instance ( MimeRender ctyp a
|
|||
pctyps = Proxy :: Proxy (ctyp' ': ctyps)
|
||||
|
||||
|
||||
instance AllMimeRender '[] a where
|
||||
allMimeRender _ _ = []
|
||||
-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and
|
||||
-- then this would be taken care of. However there is no more specific instance
|
||||
-- between that and 'MimeRender JSON a', so we do this instead
|
||||
instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where
|
||||
allMimeRender _ _ = [(contentType pctyp, "")]
|
||||
where pctyp = Proxy :: Proxy ctyp
|
||||
|
||||
instance OVERLAPPING_
|
||||
( AllMime (ctyp ': ctyp' ': ctyps)
|
||||
) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where
|
||||
allMimeRender p _ = zip (allMime p) (repeat "")
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Check that all elements of list are instances of MimeUnrender
|
||||
|
@ -270,21 +283,19 @@ instance ( MimeUnrender ctyp a
|
|||
where pctyp = Proxy :: Proxy ctyp
|
||||
pctyps = Proxy :: Proxy ctyps
|
||||
|
||||
type family IsNonEmpty (list :: [*]) :: Constraint where
|
||||
IsNonEmpty (x ': xs) = ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * MimeRender Instances
|
||||
|
||||
-- | `encode`
|
||||
instance ToJSON a => MimeRender JSON a where
|
||||
instance OVERLAPPABLE_
|
||||
ToJSON a => MimeRender JSON a where
|
||||
mimeRender _ = encode
|
||||
|
||||
-- | @encodeFormUrlEncoded . toFormUrlEncoded@
|
||||
-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
|
||||
-- holds if every element of x is non-null (i.e., not @("", "")@)
|
||||
instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
|
||||
instance OVERLAPPABLE_
|
||||
ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
|
||||
mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded
|
||||
|
||||
-- | `TextL.encodeUtf8`
|
||||
|
@ -307,6 +318,10 @@ instance MimeRender OctetStream ByteString where
|
|||
instance MimeRender OctetStream BS.ByteString where
|
||||
mimeRender _ = fromStrict
|
||||
|
||||
-- | A type for responses without content-body.
|
||||
data NoContent = NoContent
|
||||
deriving (Show, Eq, Read)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * MimeUnrender Instances
|
||||
|
|
|
@ -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 }
|
|
@ -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 }
|
|
@ -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 }
|
|
@ -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 }
|
|
@ -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 }
|
169
servant/src/Servant/API/Verbs.hs
Normal file
169
servant/src/Servant/API/Verbs.hs
Normal file
|
@ -0,0 +1,169 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
module Servant.API.Verbs
|
||||
( module Servant.API.Verbs
|
||||
, StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH)
|
||||
) where
|
||||
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Proxy (Proxy)
|
||||
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 (a.k.a. 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)
|
||||
|
||||
-- * 200 responses
|
||||
--
|
||||
-- The 200 response is the workhorse of web servers, but also fairly generic.
|
||||
-- When appropriate, you should prefer the more specific success combinators.
|
||||
-- More information about the definitions of status codes can be found in
|
||||
-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC2615> and
|
||||
-- <https://tools.ietf.org/html/rfc7231#section-6 RFC7231 Section 6>;
|
||||
-- the relevant information is summarily presented here.
|
||||
|
||||
-- | '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
|
||||
|
||||
-- * Other responses
|
||||
|
||||
-- ** 201 Created
|
||||
--
|
||||
-- Indicates that a new resource has been created. The URI corresponding to the
|
||||
-- resource should be given in the @Location@ header field.
|
||||
--
|
||||
-- If the resource cannot be created immediately, use 'PostAccepted'.
|
||||
--
|
||||
-- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header
|
||||
-- field.
|
||||
|
||||
-- | 'POST' with 201 status code.
|
||||
--
|
||||
type PostCreated contentTypes a = Verb 'POST 201 contentTypes a
|
||||
|
||||
|
||||
-- ** 202 Accepted
|
||||
--
|
||||
-- Indicates that the request has been accepted for processing, but the
|
||||
-- processing has not yet completed. The status of the processing should be
|
||||
-- included, as well as either a link to a status monitoring endpoint or an
|
||||
-- estimate of when the processing will be finished.
|
||||
|
||||
-- | 'GET' with 202 status code.
|
||||
type GetAccepted contentTypes a = Verb 'GET 202 contentTypes a
|
||||
-- | 'POST' with 202 status code.
|
||||
type PostAccepted contentTypes a = Verb 'POST 202 contentTypes a
|
||||
-- | 'DELETE' with 202 status code.
|
||||
type DeleteAccepted contentTypes a = Verb 'DELETE 202 contentTypes a
|
||||
-- | 'PATCH' with 202 status code.
|
||||
type PatchAccepted contentTypes a = Verb 'PATCH 202 contentTypes a
|
||||
-- | 'PUT' with 202 status code.
|
||||
type PutAccepted contentTypes a = Verb 'PUT 202 contentTypes a
|
||||
|
||||
|
||||
-- ** 203 Non-Authoritative Information
|
||||
--
|
||||
-- Indicates that the request has been successfully processed, but the
|
||||
-- information may come from a third-party.
|
||||
|
||||
-- | 'GET' with 203 status code.
|
||||
type GetNonAuthoritative contentTypes a = Verb 'GET 203 contentTypes a
|
||||
-- | 'POST' with 203 status code.
|
||||
type PostNonAuthoritative contentTypes a = Verb 'POST 203 contentTypes a
|
||||
-- | 'DELETE' with 203 status code.
|
||||
type DeleteNonAuthoritative contentTypes a = Verb 'DELETE 203 contentTypes a
|
||||
-- | 'PATCH' with 203 status code.
|
||||
type PatchNonAuthoritative contentTypes a = Verb 'PATCH 203 contentTypes a
|
||||
-- | 'PUT' with 203 status code.
|
||||
type PutNonAuthoritative contentTypes a = Verb 'PUT 203 contentTypes a
|
||||
|
||||
|
||||
-- ** 204 No Content
|
||||
--
|
||||
-- Indicates that no response body is being returned. Handlers for these should
|
||||
-- return 'NoContent', possibly with headers.
|
||||
--
|
||||
-- If the document view should be reset, use @205 Reset Content@.
|
||||
|
||||
-- | 'GET' with 204 status code.
|
||||
type GetNoContent contentTypes noContent = Verb 'GET 204 contentTypes noContent
|
||||
-- | 'POST' with 204 status code.
|
||||
type PostNoContent contentTypes noContent = Verb 'POST 204 contentTypes noContent
|
||||
-- | 'DELETE' with 204 status code.
|
||||
type DeleteNoContent contentTypes noContent = Verb 'DELETE 204 contentTypes noContent
|
||||
-- | 'PATCH' with 204 status code.
|
||||
type PatchNoContent contentTypes noContent = Verb 'PATCH 204 contentTypes noContent
|
||||
-- | 'PUT' with 204 status code.
|
||||
type PutNoContent contentTypes noContent = Verb 'PUT 204 contentTypes noContent
|
||||
|
||||
|
||||
-- ** 205 Reset Content
|
||||
--
|
||||
-- Indicates that no response body is being returned. Handlers for these should
|
||||
-- return 'NoContent', possibly with Headers.
|
||||
--
|
||||
-- If the document view should not be reset, use @204 No Content@.
|
||||
|
||||
-- | 'GET' with 205 status code.
|
||||
type GetResetContent contentTypes noContent = Verb 'GET 205 contentTypes noContent
|
||||
-- | 'POST' with 205 status code.
|
||||
type PostResetContent contentTypes noContent = Verb 'POST 205 contentTypes noContent
|
||||
-- | 'DELETE' with 205 status code.
|
||||
type DeleteResetContent contentTypes noContent = Verb 'DELETE 205 contentTypes noContent
|
||||
-- | 'PATCH' with 205 status code.
|
||||
type PatchResetContent contentTypes noContent = Verb 'PATCH 205 contentTypes noContent
|
||||
-- | 'PUT' with 205 status code.
|
||||
type PutResetContent contentTypes noContent = Verb 'PUT 205 contentTypes noContent
|
||||
|
||||
|
||||
-- ** 206 Partial Content
|
||||
--
|
||||
-- Indicates that the server is delivering part of the resource due to a range
|
||||
-- header in the request.
|
||||
--
|
||||
-- For more information, see <https://tools.ietf.org/html/rfc7233#section-4.1
|
||||
-- RFC7233 Section 4.1>
|
||||
|
||||
-- | 'GET' with 206 status code.
|
||||
type GetPartialContent contentTypes noContent = Verb 'GET 206 contentTypes noContent
|
||||
|
||||
|
||||
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
|
|
@ -74,7 +74,7 @@
|
|||
-- >>> safeLink api bad_link
|
||||
-- ...
|
||||
-- Could not deduce (Or
|
||||
-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))
|
||||
-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int))
|
||||
-- (IsElem'
|
||||
-- ("hello" :> Delete '[JSON] ())
|
||||
-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))
|
||||
|
@ -119,11 +119,7 @@ import Servant.API.Capture ( Capture )
|
|||
import Servant.API.ReqBody ( ReqBody )
|
||||
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
|
||||
import Servant.API.Header ( Header )
|
||||
import Servant.API.Get ( Get )
|
||||
import Servant.API.Post ( Post )
|
||||
import Servant.API.Put ( Put )
|
||||
import Servant.API.Patch ( Patch )
|
||||
import Servant.API.Delete ( Delete )
|
||||
import Servant.API.Verbs ( Verb )
|
||||
import Servant.API.Sub ( type (:>) )
|
||||
import Servant.API.Raw ( Raw )
|
||||
import Servant.API.Alternative ( type (:<|>) )
|
||||
|
@ -177,11 +173,8 @@ type family IsElem endpoint api :: Constraint where
|
|||
IsElem sa (QueryParam x y :> sb) = IsElem sa sb
|
||||
IsElem sa (QueryParams x y :> sb) = IsElem sa sb
|
||||
IsElem sa (QueryFlag x :> sb) = IsElem sa sb
|
||||
IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'
|
||||
IsElem (Post ct typ) (Post ct' typ) = 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 (Verb m s ct typ) (Verb m s ct' typ)
|
||||
= IsSubList ct ct'
|
||||
IsElem e e = ()
|
||||
IsElem e a = IsElem' e a
|
||||
|
||||
|
@ -303,24 +296,8 @@ instance HasLink sub => HasLink (Header sym a :> sub) where
|
|||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
|
||||
-- Verb (terminal) instances
|
||||
instance HasLink (Get y r) where
|
||||
type MkLink (Get y r) = 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
|
||||
instance HasLink (Verb m s ct a) where
|
||||
type MkLink (Verb m s ct a) = URI
|
||||
toLink _ = linkURI
|
||||
|
||||
instance HasLink Raw where
|
||||
|
|
Loading…
Reference in a new issue