Merge pull request #59 from codedmart/deleteResponseBody

modify delete to allow for response body

servant-client/CHANGELOG.md

@@ -1,5 +1,6 @@
 0.3
 ---
+* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body
 * Support content-type aware combinators and `Accept`/`Content-type` headers
 * Added a lot of tests
 * Support multiple concurrent threads

servant-client/src/Servant/Client.hs

@@ -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
+instance
-  type Client Delete = BaseUrl -> EitherT ServantError IO ()
+#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'

servant-client/test/Servant/ClientSpec.hs

@@ -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
+  context "Servant.API.Delete" $ do
-    (Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()
+    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") :

servant-docs/CHANGELOG.md

@@ -1,5 +1,6 @@
 0.4
 ---
+* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body
 * Allow for extra information to be added to the docs
 * Support content-type aware combinators of *servant-0.3*
 * Render endpoints in a canonical order (https://github.com/haskell-servant/servant-docs/pull/15)

servant-docs/example/greet.hs

@@ -53,6 +53,9 @@ instance ToParam (MatrixParam "lang" String) where
                   "Get the greeting message selected language. Default is en."
                   Normal
 
+instance ToSample () () where
+  toSample _ = Just ()
+
 instance ToSample Greet Greet where
   toSample _ = Just $ Greet "Hello, haskeller!"
 
@@ -90,7 +93,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 +103,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"]

servant-docs/src/Servant/Docs/Internal.hs

@@ -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 .~ []
+instance
-                           & response.respStatus .~ 204
+#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)

servant-jquery/CHANGELOG.md

@@ -1,5 +1,6 @@
 0.3
 ---
+* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body
 * Extend `HeaderArg` to support more advanced HTTP header handling (https://github.com/haskell-servant/servant-jquery/pull/6)
 * Support content-type aware combinators (but require that endpoints support JSON)
 * Add support for Matrix params (https://github.com/haskell-servant/servant-jquery/pull/11)

servant-jquery/src/Servant/JQuery/Internal.hs

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

servant-server/CHANGELOG.md

@@ -1,5 +1,6 @@
 0.3
 ---
+* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body
 * Add a `RouteMismatch` constructor for arbitrary HTTP response codes (https://github.com/haskell-servant/servant-server/pull/22)
 * Add support for the `Patch` combinator
 * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3*

servant-server/example/greet.hs

@@ -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

servant-server/src/Servant/Server/Internal.hs

@@ -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
+        respond $ case e of
-          Right () -> responseLBS status204 [] ""
+          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

servant-server/test/Servant/ServerSpec.hs

@@ -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
 

servant/CHANGELOG.md

@@ -1,5 +1,6 @@
 0.3
 ---
+* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body
 * Multiple content-type/accept support for all the relevant combinators
 * Provide *JSON*, *PlainText*, *OctetStream* and *FormUrlEncoded* content types out of the box
 * Type-safe link generation to API endpoints

servant/src/Servant/API/Delete.hs

@@ -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
 
 

servant/src/Servant/Utils/Links.hs

@@ -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)
+--                            ("hello" :> Delete '[JSON] ())
---                            ("bye" :> (QueryParam "name" String :> Delete))))
+--                            ("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
+instance HasLink (Delete y r) where
-    type MkLink Delete = URI
+    type MkLink (Delete y r) = URI
     toLink _ = linkURI
 
 instance HasLink Raw where

servant/test/Servant/Utils/LinksSpec.hs

@@ -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
+  :<|> "ducks" :> MatrixFlag "yellow" :> MatrixFlag "loud" :> Delete '[JSON] ()
-  :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete
+  :<|> "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"