10a6020 · servant · git.iko.soy

git.iko.soy/servant

modify delete to allow for response body

commit10a6020ca2aaedd8e5ec2cffa782b5a1b5978d17 authorBrandon Martin <zmbmartin@gmail.com> dateWed 6 May 2015, 13:21 (11 years ago) parent09d901d

11 files changed+167−40

compare with master

unifiedsplit

servant-client/src/Servant/Client.hs+33−3 servant-client/test/Servant/ClientSpec.hs+12−4 servant-docs/example/greet.hs+10−2 servant-docs/src/Servant/Docs/Internal.hs+27−3 servant-jquery/src/Servant/JQuery/Internal.hs+2−2 servant-server/example/greet.hs+1−1 servant-server/src/Servant/Server/Internal.hs+58−4 servant-server/test/Servant/ServerSpec.hs+2−2 servant/src/Servant/API/Delete.hs+3−1 servant/src/Servant/Utils/Links.hs+10−9 servant/test/Servant/Utils/LinksSpec.hs+9−9

servant-client/src/Servant/Client.hs+33−3

@@ -117,11 +117,41 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)

117117-- side querying function that is created when calling 'client'

118118-- will just require an argument that specifies the scheme, host

119119-- and port to send the request to.

120−instance HasClient Delete where

121− type Client Delete = BaseUrl -> EitherT ServantError IO ()

120+instance

121+#if MIN_VERSION_base(4,8,0)

122+ {-# OVERLAPPABLE #-}

123+#endif

124+ (MimeUnrender ct a) => HasClient (Delete (ct ': cts) a) where

125+ type Client (Delete (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a

126+ clientWithRoute Proxy req host =

127+ snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] host

122128

129+-- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content

130+-- HTTP header.

131+instance

132+#if MIN_VERSION_base(4,8,0)

133+ {-# OVERLAPPING #-}

134+#endif

135+ HasClient (Delete (ct ': cts) ()) where

136+ type Client (Delete (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()

123137 clientWithRoute Proxy req host =

124− void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host

138+ void $ performRequestNoBody H.methodDelete req [204] host

139+

140+-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the

141+-- corresponding headers.

142+instance

143+#if MIN_VERSION_base(4,8,0)

144+ {-# OVERLAPPING #-}

145+#endif

146+ ( MimeUnrender ct a, BuildHeadersTo ls

147+ ) => HasClient (Delete (ct ': cts) (Headers ls a)) where

148+ type Client (Delete (ct ': cts) (Headers ls a)) = BaseUrl -> EitherT ServantError IO (Headers ls a)

149+ clientWithRoute Proxy req host = do

150+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] host

151+ return $ Headers { getResponse = resp

152+ , getHeadersHList = buildHeadersTo hdrs

153+ }

154+

125155

126156-- | If you have a 'Get' endpoint in your API, the client

127157-- side querying function that is created when calling 'client'

servant-client/test/Servant/ClientSpec.hs+12−4

@@ -79,7 +79,8 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]

7979

8080type Api =

8181 "get" :> Get '[JSON] Person

82− :<|> "delete" :> Delete

82+ :<|> "delete" :> Delete '[JSON] ()

83+ :<|> "deleteString" :> Delete '[JSON] String

8384 :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person

8485 :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person

8586 :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person

@@ -104,6 +105,7 @@ server :: Application

104105server = serve api (

105106 return alice

106107 :<|> return ()

108+ :<|> return "ok"

107109 :<|> (\ name -> return $ Person name 0)

108110 :<|> return

109111 :<|> (\ name -> case name of

@@ -129,6 +131,7 @@ withServer action = withWaiDaemon (return server) action

129131

130132getGet :: BaseUrl -> EitherT ServantError IO Person

131133getDelete :: BaseUrl -> EitherT ServantError IO ()

134+getDeleteString :: BaseUrl -> EitherT ServantError IO String

132135getCapture :: String -> BaseUrl -> EitherT ServantError IO Person

133136getBody :: Person -> BaseUrl -> EitherT ServantError IO Person

134137getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person

@@ -147,6 +150,7 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

147150getRespHeaders :: BaseUrl -> EitherT ServantError IO (Headers TestHeaders Bool)

148151( getGet

149152 :<|> getDelete

153+ :<|> getDeleteString

150154 :<|> getCapture

151155 :<|> getBody

152156 :<|> getQueryParam

@@ -183,8 +187,12 @@ spec = do

183187 it "Servant.API.Get" $ withServer $ \ host -> do

184188 (Arrow.left show <$> runEitherT (getGet host)) `shouldReturn` Right alice

185189

186− it "Servant.API.Delete" $ withServer $ \ host -> do

187− (Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()

190+ context "Servant.API.Delete" $ do

191+ it "return no body" $ withServer $ \ host -> do

192+ (Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()

193+

194+ it "return body" $ withServer $ \ host -> do

195+ (Arrow.left show <$> runEitherT (getDeleteString host)) `shouldReturn` Right "ok"

188196

189197 it "Servant.API.Capture" $ withServer $ \ host -> do

190198 (Arrow.left show <$> runEitherT (getCapture "Paula" host)) `shouldReturn` Right (Person "Paula" 0)

@@ -268,7 +276,7 @@ spec = do

268276 Left FailureResponse{..} <- runEitherT (getResponse host)

269277 responseStatus `shouldBe` (Status 500 "error message")

270278 mapM_ test $

271− (WrappedApi (Proxy :: Proxy Delete), "Delete") :

279+ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

272280 (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :

273281 (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :

274282 (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :

servant-docs/example/greet.hs+10−2

@@ -53,6 +53,14 @@ instance ToParam (MatrixParam "lang" String) where

5353 "Get the greeting message selected language. Default is en."

5454 Normal

5555

56+instance ToSample () Greet where

57+ toSample _ = Just $ Greet "Hello, haskeller!"

58+

59+ toSamples _ =

60+ [ ("If you use ?capital=true", Greet "HELLO, HASKELLER")

61+ , ("If you use ?capital=false", Greet "Hello, haskeller")

62+ ]

63+

5664instance ToSample Greet Greet where

5765 toSample _ = Just $ Greet "Hello, haskeller!"

5866

@@ -90,7 +98,7 @@ type TestApi =

9098 :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet)

9199

92100 -- DELETE /greet/:greetid

93− :<|> "greet" :> Capture "greetid" Text :> Delete

101+ :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] ()

94102

95103testApi :: Proxy TestApi

96104testApi = Proxy

@@ -100,7 +108,7 @@ testApi = Proxy

100108-- notes.

101109extra :: ExtraInfo TestApi

102110extra =

103− extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $

111+ extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] ())) $

104112 defAction & headers <>~ ["unicorns"]

105113 & notes <>~ [ DocNote "Title" ["This is some text"]

106114 , DocNote "Second secton" ["And some more"]

servant-docs/src/Servant/Docs/Internal.hs+27−3

@@ -651,14 +651,38 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout)

651651 symP = Proxy :: Proxy sym

652652

653653

654−instance HasDocs Delete where

654+instance

655+#if MIN_VERSION_base(4,8,0)

656+ {-# OVERLAPPABLe #-}

657+#endif

658+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts)

659+ => HasDocs (Delete cts a) where

655660 docsFor Proxy (endpoint, action) =

656661 single endpoint' action'

657662

658663 where endpoint' = endpoint & method .~ DocDELETE

664+ action' = action & response.respBody .~ sampleByteStrings t p

665+ & response.respTypes .~ supportedTypes t

666+ t = Proxy :: Proxy cts

667+ p = Proxy :: Proxy a

668+

669+instance

670+#if MIN_VERSION_base(4,8,0)

671+ {-# OVERLAPPING #-}

672+#endif

673+ (ToSample a b, IsNonEmpty cts, AllMimeRender cts b, SupportedTypes cts

674+ , AllHeaderSamples ls , GetHeaders (HList ls) )

675+ => HasDocs (Delete cts (Headers ls a)) where

676+ docsFor Proxy (endpoint, action) =

677+ single endpoint' action'

659678

660− action' = action & response.respBody .~ []

661− & response.respStatus .~ 204

679+ where hdrs = allHeaderToSample (Proxy :: Proxy ls)

680+ endpoint' = endpoint & method .~ DocDELETE

681+ action' = action & response.respBody .~ sampleByteStrings t p

682+ & response.respTypes .~ supportedTypes t

683+ & response.respHeaders .~ hdrs

684+ t = Proxy :: Proxy cts

685+ p = Proxy :: Proxy a

662686

663687instance

664688#if MIN_VERSION_base(4,8,0)

servant-jquery/src/Servant/JQuery/Internal.hs+2−2

@@ -215,8 +215,8 @@ instance (KnownSymbol sym, HasJQ sublayout)

215215

216216 where str = symbolVal (Proxy :: Proxy sym)

217217

218−instance HasJQ Delete where

219− type JQ Delete = AjaxReq

218+instance Elem JSON list => HasJQ (Delete list a) where

219+ type JQ (Delete list a) = AjaxReq

220220

221221 jqueryFor Proxy req =

222222 req & funcName %~ ("delete" <>)

servant-server/example/greet.hs+1−1

@@ -34,7 +34,7 @@ type TestApi =

3434 :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet

3535

3636 -- DELETE /greet/:greetid

37− :<|> "greet" :> Capture "greetid" Text :> Delete

37+ :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] ()

3838

3939testApi :: Proxy TestApi

4040testApi = Proxy

servant-server/src/Servant/Server/Internal.hs+58−4

@@ -258,20 +258,74 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)

258258-- to be returned. You can use 'Control.Monad.Trans.Either.left' to

259259-- painlessly error out if the conditions for a successful deletion

260260-- are not met.

261−instance HasServer Delete where

261+instance

262+#if MIN_VERSION_base(4,8,0)

263+ {-# OVERLAPPABLE #-}

264+#endif

265+ ( AllCTRender ctypes a

266+ ) => HasServer (Delete ctypes a) where

267+

268+ type ServerT (Delete ctypes a) m = m a

269+

270+ route Proxy action request respond

271+ | pathIsEmpty request && requestMethod request == methodDelete = do

272+ e <- runEitherT action

273+ respond $ case e of

274+ Right output -> do

275+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

276+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

277+ Nothing -> failWith UnsupportedMediaType

278+ Just (contentT, body) -> succeedWith $

279+ responseLBS status200 [ ("Content-Type" , cs contentT)] body

280+ Left err -> succeedWith $ responseServantErr err

281+ | pathIsEmpty request && requestMethod request /= methodDelete =

282+ respond $ failWith WrongMethod

283+ | otherwise = respond $ failWith NotFound

284+

285+instance

286+#if MIN_VERSION_base(4,8,0)

287+ {-# OVERLAPPING #-}

288+#endif

289+ HasServer (Delete ctypes ()) where

262290

263− type ServerT Delete m = m ()

291+ type ServerT (Delete ctypes ()) m = m ()

264292

265293 route Proxy action request respond

266294 | pathIsEmpty request && requestMethod request == methodDelete = do

267295 e <- runEitherT action

268− respond $ succeedWith $ case e of

269− Right () -> responseLBS status204 [] ""

296+ respond . succeedWith $ case e of

297+ Right () -> responseLBS noContent204 [] ""

270298 Left err -> responseServantErr err

271299 | pathIsEmpty request && requestMethod request /= methodDelete =

272300 respond $ failWith WrongMethod

273301 | otherwise = respond $ failWith NotFound

274302

303+-- Add response headers

304+instance

305+#if MIN_VERSION_base(4,8,0)

306+ {-# OVERLAPPING #-}

307+#endif

308+ ( GetHeaders (Headers h v), AllCTRender ctypes v

309+ ) => HasServer (Delete ctypes (Headers h v)) where

310+

311+ type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)

312+

313+ route Proxy action request respond

314+ | pathIsEmpty request && requestMethod request == methodDelete = do

315+ e <- runEitherT action

316+ respond $ case e of

317+ Right output -> do

318+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

319+ headers = getHeaders output

320+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

321+ Nothing -> failWith UnsupportedMediaType

322+ Just (contentT, body) -> succeedWith $

323+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

324+ Left err -> succeedWith $ responseServantErr err

325+ | pathIsEmpty request && requestMethod request /= methodDelete =

326+ respond $ failWith WrongMethod

327+ | otherwise = respond $ failWith NotFound

328+

275329-- | When implementing the handler for a 'Get' endpoint,

276330-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'

277331-- and 'Servant.API.Put.Put', the handler code runs in the

servant-server/test/Servant/ServerSpec.hs+2−2

@@ -443,7 +443,7 @@ patchSpec = do

443443 , "application/nonsense")]

444444 patch'' "/" "anything at all" `shouldRespondWith` 415

445445

446−type HeaderApi a = Header "MyHeader" a :> Delete

446+type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] ()

447447headerApi :: Proxy (HeaderApi a)

448448headerApi = Proxy

449449

@@ -503,7 +503,7 @@ type AlternativeApi =

503503 :<|> "foo" :> Get '[PlainText] T.Text

504504 :<|> "bar" :> Post '[JSON] Animal

505505 :<|> "bar" :> Put '[JSON] Animal

506− :<|> "bar" :> Delete

506+ :<|> "bar" :> Delete '[JSON] ()

507507unionApi :: Proxy AlternativeApi

508508unionApi = Proxy

509509

servant/src/Servant/API/Delete.hs+3−1

@@ -1,4 +1,6 @@

1+{-# LANGUAGE DataKinds #-}

12{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE KindSignatures #-}

24{-# OPTIONS_HADDOCK not-home #-}

35module Servant.API.Delete (Delete) where

@@ -10,7 +12,7 @@ import Data.Typeable ( Typeable )

1012--

1113-- >>> -- DELETE /books/:isbn

1214-- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete

13−data Delete

15+data Delete (contentTypes :: [*]) a

1416 deriving Typeable

1517

1618

servant/src/Servant/Utils/Links.hs+10−9

@@ -22,7 +22,7 @@

2222-- >>>

2323-- >>>

2424-- >>> type Hello = "hello" :> Get '[JSON] Int

25−-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete

25+-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] ()

2626-- >>> type API = Hello :<|> Bye

2727-- >>> let api = Proxy :: Proxy API

2828--

@@ -48,11 +48,11 @@

4848-- If the API has an endpoint with parameters then we can generate links with

4949-- or without those:

5050--

51−-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete)

51+-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] ())

5252-- >>> print $ safeLink api with "Hubert"

5353-- bye?name=Hubert

5454--

55−-- >>> let without = Proxy :: Proxy ("bye" :> Delete)

55+-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] ())

5656-- >>> print $ safeLink api without

5757-- bye

5858--

@@ -70,15 +70,15 @@

7070-- Attempting to construct a link to an endpoint that does not exist in api

7171-- will result in a type error like this:

7272--

73−-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete)

73+-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] ())

7474-- >>> safeLink api bad_link

7575-- <BLANKLINE>

7676-- <interactive>:64:1:

7777-- Could not deduce (Or

78−-- (IsElem' Delete (Get '[JSON] Int))

78+-- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int))

7979-- (IsElem'

80−-- ("hello" :> Delete)

81−-- ("bye" :> (QueryParam "name" String :> Delete))))

80+-- ("hello" :> Delete '[JSON] ())

81+-- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ()))))

8282-- arising from a use of ‘safeLink’

8383-- In the expression: safeLink api bad_link

8484-- In an equation for ‘it’: it = safeLink api bad_link

@@ -176,6 +176,7 @@ type family IsElem endpoint api :: Constraint where

176176 IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct'

177177 IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct'

178178 IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct'

179+ IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct'

179180 IsElem e e = ()

180181 IsElem e a = IsElem' e a

181182

@@ -349,8 +350,8 @@ instance HasLink (Put y r) where

349350 type MkLink (Put y r) = URI

350351 toLink _ = linkURI

351352

352−instance HasLink Delete where

353− type MkLink Delete = URI

353+instance HasLink (Delete y r) where

354+ type MkLink (Delete y r) = URI

354355 toLink _ = linkURI

355356

356357instance HasLink Raw where

servant/test/Servant/Utils/LinksSpec.hs+9−9

@@ -12,20 +12,20 @@ import Servant.API

1212

1313type TestApi =

1414 -- Capture and query/matrix params

15− "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete

15+ "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] ()

1616

1717 :<|> "parent" :> MatrixParams "name" String :> "child"

1818 :> MatrixParam "gender" String :> Get '[JSON] String

1919

2020 -- Flags

21− :<|> "ducks" :> MatrixFlag "yellow" :> MatrixFlag "loud" :> Delete

22− :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete

21+ :<|> "ducks" :> MatrixFlag "yellow" :> MatrixFlag "loud" :> Delete '[JSON] ()

22+ :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] ()

2323

2424 -- All of the verbs

2525 :<|> "get" :> Get '[JSON] ()

2626 :<|> "put" :> Put '[JSON] ()

2727 :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] ()

28− :<|> "delete" :> Header "ponies" :> Delete

28+ :<|> "delete" :> Header "ponies" :> Delete '[JSON] ()

2929 :<|> "raw" :> Raw

3030

3131type TestLink = "hello" :> "hi" :> Get '[JSON] Bool

@@ -55,12 +55,12 @@ shouldBeURI link expected =

5555spec :: Spec

5656spec = describe "Servant.Utils.Links" $ do

5757 it "Generates correct links for capture query and matrix params" $ do

58− let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete)

58+ let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] ())

5959 apiLink l1 "hi" `shouldBeURI` "hello/hi"

6060

6161 let l2 = Proxy :: Proxy ("hello" :> Capture "name" String

6262 :> QueryParam "capital" Bool

63− :> Delete)

63+ :> Delete '[JSON] ())

6464 apiLink l2 "bye" True `shouldBeURI` "hello/bye?capital=true"

6565

6666 let l3 = Proxy :: Proxy ("parent" :> MatrixParams "name" String

@@ -73,12 +73,12 @@ spec = describe "Servant.Utils.Links" $ do

7373

7474 it "Generates correct links for query and matrix flags" $ do

7575 let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy"

76− :> QueryFlag "fast" :> Delete)

76+ :> QueryFlag "fast" :> Delete '[JSON] ())

7777 apiLink l1 True True `shouldBeURI` "balls?bouncy&fast"

7878 apiLink l1 False True `shouldBeURI` "balls?fast"

7979

8080 let l2 = Proxy :: Proxy ("ducks" :> MatrixFlag "yellow"

81− :> MatrixFlag "loud" :> Delete)

81+ :> MatrixFlag "loud" :> Delete '[JSON] ())

8282 apiLink l2 True True `shouldBeURI` "ducks;yellow;loud"

8383 apiLink l2 False True `shouldBeURI` "ducks;loud"

8484

@@ -86,5 +86,5 @@ spec = describe "Servant.Utils.Links" $ do

8686 apiLink (Proxy :: Proxy ("get" :> Get '[JSON] ())) `shouldBeURI` "get"

8787 apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put"

8888 apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post"

89− apiLink (Proxy :: Proxy ("delete" :> Delete)) `shouldBeURI` "delete"

89+ apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete"

9090 apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeURI` "raw"