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

modify delete to allow for response body

Browse Source
This commit is contained in:
Brandon Martin 2015-05-06 13:21:35 -06:00
parent 09d901d87c
commit 10a6020ca2
11 changed files with 168 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
servant-client/src/Servant/Client.hs
View File

@ -117,11 +117,41 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
-- 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 HasClient Delete where
type Client Delete = BaseUrl -> EitherT ServantError IO ()
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
(MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where
type Client (Delete (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req host =
void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] host
-- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content
-- HTTP header.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasClient (Delete (ct ': cts) ()) where
type Client (Delete (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodDelete req [204] host
-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Delete (ct ': cts) (Headers ls a)) where
type Client (Delete (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)
clientWithRoute Proxy req host = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] host
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'

16
servant-client/test/Servant/ClientSpec.hs
View File

@ -79,7 +79,8 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
type Api =
"get" :> Get '[JSON] Person
:<|> "delete" :> Delete
:<|> "delete" :> Delete '[JSON] ()
:<|> "deleteString" :> Delete '[JSON] String
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
@ -104,6 +105,7 @@ server :: Application
server = serve api (
return alice
:<|> return ()
:<|> return "ok"
:<|> (\ name -> return $ Person name 0)
:<|> return
:<|> (\ name -> case name of
@ -129,6 +131,7 @@ withServer action = withWaiDaemon (return server) action
getGet :: BaseUrl -> EitherT ServantError IO Person
getDelete :: BaseUrl -> EitherT ServantError IO ()
getDeleteString :: BaseUrl -> EitherT ServantError IO String
getCapture :: String -> BaseUrl -> EitherT ServantError IO Person
getBody :: Person -> BaseUrl -> EitherT ServantError IO Person
getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
@ -147,6 +150,7 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)
( getGet
:<|> getDelete
:<|> getDeleteString
:<|> getCapture
:<|> getBody
:<|> getQueryParam
@ -183,8 +187,12 @@ spec = do
it "Servant.API.Get" $ withServer $ \ host -> do
(Arrow.left show <$> runEitherT (getGet host)) `shouldReturn` Right alice
it "Servant.API.Delete" $ withServer $ \ host -> do
(Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()
context "Servant.API.Delete" $ do
it "return no body" $ withServer $ \ host -> do
(Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()
it "return body" $ withServer $ \ host -> do
(Arrow.left show <$> runEitherT (getDeleteString host)) `shouldReturn` Right "ok"
it "Servant.API.Capture" $ withServer $ \ host -> do
(Arrow.left show <$> runEitherT (getCapture "Paula" host)) `shouldReturn` Right (Person "Paula" 0)
@ -268,7 +276,7 @@ spec = do
Left FailureResponse{..} <- runEitherT (getResponse host)
responseStatus `shouldBe` (Status 500 "error message")
mapM_ test $
(WrappedApi (Proxy :: Proxy Delete), "Delete") :
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
(WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
(WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :

12
servant-docs/example/greet.hs
View File

@ -53,6 +53,14 @@ instance ToParam (MatrixParam "lang" String) where
"Get the greeting message selected language. Default is en."
Normal
instance ToSample () Greet where
toSample _ = Just $ Greet "Hello, haskeller!"
toSamples _ =
[ ("If you use ?capital=true", Greet "HELLO, HASKELLER")
, ("If you use ?capital=false", Greet "Hello, haskeller")
]
instance ToSample Greet Greet where
toSample _ = Just $ Greet "Hello, haskeller!"
@ -90,7 +98,7 @@ type TestApi =
:<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet)
-- DELETE /greet/:greetid
:<|> "greet" :> Capture "greetid" Text :> Delete
:<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] ()
testApi :: Proxy TestApi
testApi = Proxy
@ -100,7 +108,7 @@ testApi = Proxy
-- notes.
extra :: ExtraInfo TestApi
extra =
extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] ())) $
defAction & headers <>~ ["unicorns"]
& notes <>~ [ DocNote "Title" ["This is some text"]
, DocNote "Second secton" ["And some more"]

30
servant-docs/src/Servant/Docs/Internal.hs
View File

@ -651,14 +651,38 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)
symP = Proxy :: Proxy sym
instance HasDocs Delete where
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLe #-}
#endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)
=> HasDocs (Delete cts a) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where endpoint' = endpoint & method .~ DocDELETE
action' = action & response.respBody .~ sampleByteStrings t p
& response.respTypes .~ supportedTypes t
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
action' = action & response.respBody .~ []
& response.respStatus .~ 204
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
(ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts
, AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Delete cts (Headers ls a)) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocDELETE
action' = action & response.respBody .~ sampleByteStrings t p
& response.respTypes .~ supportedTypes t
& response.respHeaders .~ hdrs
t = Proxy :: Proxy cts
p = Proxy :: Proxy a
instance
#if MIN_VERSION_base(4,8,0)

4
servant-jquery/src/Servant/JQuery/Internal.hs
View File

@ -215,8 +215,8 @@ instance (KnownSymbol sym, HasJQ sublayout)
where str = symbolVal (Proxy :: Proxy sym)
instance HasJQ Delete where
type JQ Delete = AjaxReq
instance Elem JSON list => HasJQ (Delete list a) where
type JQ (Delete list a) = AjaxReq
jqueryFor Proxy req =
req & funcName %~ ("delete" <>)

2
servant-server/example/greet.hs
View File

@ -34,7 +34,7 @@ type TestApi =
:<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
-- DELETE /greet/:greetid
:<|> "greet" :> Capture "greetid" Text :> Delete
:<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] ()
testApi :: Proxy TestApi
testApi = Proxy

62
servant-server/src/Servant/Server/Internal.hs
View File

@ -258,20 +258,74 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
-- to be returned. You can use 'Control.Monad.Trans.Either.left' to
-- painlessly error out if the conditions for a successful deletion
-- are not met.
instance HasServer Delete where
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#endif
( AllCTRender ctypes a
) => HasServer (Delete ctypes a) where
type ServerT Delete m = m ()
type ServerT (Delete ctypes a) m = m a
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond $ succeedWith $ case e of
Right () -> responseLBS status204 [] ""
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 [ ("Content-Type" , cs contentT)] body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HasServer (Delete ctypes ()) where
type ServerT (Delete ctypes ()) m = m ()
route Proxy action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond . succeedWith $ case e of
Right () -> responseLBS noContent204 [] ""
Left err -> responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- Add response headers
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
( 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 action request respond
| pathIsEmpty request && requestMethod request == methodDelete = do
e <- runEitherT action
respond $ case e of
Right output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output
case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $
responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
Left err -> succeedWith $ responseServantErr err
| pathIsEmpty request && requestMethod request /= methodDelete =
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | 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

4
servant-server/test/Servant/ServerSpec.hs
View File

@ -443,7 +443,7 @@ patchSpec = do
, "application/nonsense")]
patch'' "/" "anything at all" `shouldRespondWith` 415
type HeaderApi a = Header "MyHeader" a :> Delete
type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] ()
headerApi :: Proxy (HeaderApi a)
headerApi = Proxy
@ -503,7 +503,7 @@ type AlternativeApi =
:<|> "foo" :> Get '[PlainText] T.Text
:<|> "bar" :> Post '[JSON] Animal
:<|> "bar" :> Put '[JSON] Animal
:<|> "bar" :> Delete
:<|> "bar" :> Delete '[JSON] ()
unionApi :: Proxy AlternativeApi
unionApi = Proxy

4
servant/src/Servant/API/Delete.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Delete (Delete) where
@ -10,7 +12,7 @@ import Data.Typeable ( Typeable )
--
-- >>> -- DELETE /books/:isbn
-- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete
data Delete
data Delete (contentTypes :: [*]) a
deriving Typeable

19
servant/src/Servant/Utils/Links.hs
View File

@ -22,7 +22,7 @@
-- >>>
-- >>>
-- >>> type Hello = "hello" :> Get '[JSON] Int
-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete
-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] ()
-- >>> type API = Hello :<|> Bye
-- >>> let api = Proxy :: Proxy API
--
@ -48,11 +48,11 @@
-- If the API has an endpoint with parameters then we can generate links with
-- or without those:
--
-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete)
-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] ())
-- >>> print $ safeLink api with "Hubert"
-- bye?name=Hubert
--
-- >>> let without = Proxy :: Proxy ("bye" :> Delete)
-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] ())
-- >>> print $ safeLink api without
-- bye
--
@ -70,15 +70,15 @@
-- Attempting to construct a link to an endpoint that does not exist in api
-- will result in a type error like this:
--
-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete)
-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ())
-- >>> safeLink api bad_link
-- <BLANKLINE>
-- <interactive>:64:1:
-- Could not deduce (Or
-- (IsElem' Delete (Get '[JSON] Int))
-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))
-- (IsElem'
-- ("hello" :> Delete)
-- ("bye" :> (QueryParam "name" String :> Delete))))
-- ("hello" :> Delete '[JSON] ())
-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))
-- arising from a use of ‘safeLink’
-- In the expression: safeLink api bad_link
-- In an equation for ‘it’: it = safeLink api bad_link
@ -176,6 +176,7 @@ type family IsElem endpoint api :: Constraint where
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 (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'
IsElem e e = ()
IsElem e a = IsElem' e a
@ -349,8 +350,8 @@ instance HasLink (Put y r) where
type MkLink (Put y r) = URI
toLink _ = linkURI
instance HasLink Delete where
type MkLink Delete = URI
instance HasLink (Delete y r) where
type MkLink (Delete y r) = URI
toLink _ = linkURI
instance HasLink Raw where

18
servant/test/Servant/Utils/LinksSpec.hs
View File

@ -12,20 +12,20 @@ import Servant.API
type TestApi =
-- Capture and query/matrix params
"hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete
"hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] ()
:<|> "parent" :> MatrixParams "name" String :> "child"
:> MatrixParam "gender" String :> Get '[JSON] String
-- Flags
:<|> "ducks" :> MatrixFlag "yellow" :> MatrixFlag "loud" :> Delete
:<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete
:<|> "ducks" :> MatrixFlag "yellow" :> MatrixFlag "loud" :> Delete '[JSON] ()
:<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] ()
-- All of the verbs
:<|> "get" :> Get '[JSON] ()
:<|> "put" :> Put '[JSON] ()
:<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] ()
:<|> "delete" :> Header "ponies" :> Delete
:<|> "delete" :> Header "ponies" :> Delete '[JSON] ()
:<|> "raw" :> Raw
type TestLink = "hello" :> "hi" :> Get '[JSON] Bool
@ -55,12 +55,12 @@ shouldBeURI link expected =
spec :: Spec
spec = describe "Servant.Utils.Links" $ do
it "Generates correct links for capture query and matrix params" $ do
let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete)
let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] ())
apiLink l1 "hi" `shouldBeURI` "hello/hi"
let l2 = Proxy :: Proxy ("hello" :> Capture "name" String
:> QueryParam "capital" Bool
:> Delete)
:> Delete '[JSON] ())
apiLink l2 "bye" True `shouldBeURI` "hello/bye?capital=true"
let l3 = Proxy :: Proxy ("parent" :> MatrixParams "name" String
@ -73,12 +73,12 @@ spec = describe "Servant.Utils.Links" $ do
it "Generates correct links for query and matrix flags" $ do
let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"
:> QueryFlag "fast" :> Delete)
:> QueryFlag "fast" :> Delete '[JSON] ())
apiLink l1 True True `shouldBeURI` "balls?bouncy&fast"
apiLink l1 False True `shouldBeURI` "balls?fast"
let l2 = Proxy :: Proxy ("ducks" :> MatrixFlag "yellow"
:> MatrixFlag "loud" :> Delete)
:> MatrixFlag "loud" :> Delete '[JSON] ())
apiLink l2 True True `shouldBeURI` "ducks;yellow;loud"
apiLink l2 False True `shouldBeURI` "ducks;loud"
@ -86,5 +86,5 @@ spec = describe "Servant.Utils.Links" $ do
apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get"
apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put"
apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post"
apiLink (Proxy :: Proxy ("delete" :> Delete)) `shouldBeURI` "delete"
apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete"
apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"