add client, server and docs support for the DELETE HTTP method

example/greet.hs

@@ -34,6 +34,9 @@ instance ToJSON Greet
 instance ToCapture (Capture "name" Text) where
   toCapture _ = DocCapture "name" "name of the person to greet"
 
+instance ToCapture (Capture "greetid" Text) where
+  toCapture _ = DocCapture "greetid" "identifier of the greet msg to remove"
+
 instance ToParam (GetParam "capital" Bool) where
   toParam _ =
     DocGetParam "capital"
@@ -49,13 +52,14 @@ instance ToSample Greet where
 type TestApi = 
        "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet
   :<|> "greet" :> RQBody Greet :> Post Greet
+  :<|> "delete" :> Capture "greetid" Text :> Delete
 
 testApi :: Proxy TestApi
 testApi = Proxy
 
 -- Server-side handlers
 server :: Server TestApi
-server = hello :<|> greet
+server = hello :<|> greet :<|> delete
 
   where hello name Nothing = hello name (Just False)
         hello name (Just False) = return . Greet $ "Hello, " <> name
@@ -63,18 +67,22 @@ server = hello :<|> greet
 
         greet = return
 
+        delete _ = return ()
+
 -- Client-side query functions
 clientApi :: Client TestApi
 clientApi = client testApi
 
 getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet
 postGreet :: Greet -> URI -> EitherT String IO Greet
-getGreet :<|> postGreet = clientApi
+deleteGreet :: Text -> URI -> EitherT String IO ()
+getGreet :<|> postGreet :<|> deleteGreet = clientApi
 
 -- Turn the server into a WAI app
 test :: Application
 test = serve testApi server
 
+-- Documentation
 docsGreet :: API
 docsGreet = docs testApi
 
@@ -91,6 +99,7 @@ main = do
   print =<< runEitherT (getGreet "alp" (Just False) uri)
   let g = Greet "yo"
   print =<< runEitherT (postGreet g uri)
+  print =<< runEitherT (deleteGreet "blah" uri)
   killThread tid
   putStrLn "\n---------\n"
   printMarkdown docsGreet

servant.cabal

@@ -21,6 +21,7 @@ library
     Servant.Text
     Servant.API
     Servant.API.Capture
+    Servant.API.Delete
     Servant.API.Get
     Servant.API.GetParam
     Servant.API.Post

src/Servant.hs

@@ -1,11 +1,13 @@
 module Servant
   ( module Servant.API
   , module Servant.Client
+  , module Servant.Docs
   , module Servant.Server
   , module Servant.Text
   ) where
 
 import Servant.API
 import Servant.Client
+import Servant.Docs
 import Servant.Server
 import Servant.Text

src/Servant/API.hs

@@ -1,5 +1,6 @@
 module Servant.API
   ( module Servant.API.Capture
+  , module Servant.API.Delete
   , module Servant.API.Get
   , module Servant.API.GetParam
   , module Servant.API.Post
@@ -9,6 +10,7 @@ module Servant.API
   ) where
 
 import Servant.API.Capture
+import Servant.API.Delete
 import Servant.API.Get
 import Servant.API.GetParam
 import Servant.API.Post

src/Servant/API/Delete.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Servant.API.Delete where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Either
+import Data.Proxy
+import Data.String.Conversions
+import Network.HTTP.Types
+import Network.URI
+import Network.Wai
+import Servant.Client
+import Servant.Docs
+import Servant.Server
+
+import qualified Network.HTTP.Client as Client
+
+-- | Endpoint for DELETE requests.
+data Delete
+
+instance HasServer Delete where
+  type Server Delete = EitherT (Int, String) IO ()
+
+  route Proxy action _globalPathInfo request respond
+    | null (pathInfo request) && requestMethod request == methodDelete = do
+        e <- runEitherT action
+        respond $ Just $ case e of
+          Right () ->
+            responseLBS status204 [] ""
+          Left (status, message) ->
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | otherwise = respond Nothing
+
+instance HasClient Delete where
+  type Client Delete = URI -> EitherT String IO ()
+
+  clientWithRoute Proxy req uri = do
+    partialRequest <- liftIO $ reqToRequest req uri
+
+    let request = partialRequest { Client.method = methodDelete
+                                 }
+
+    innerResponse <- liftIO . __withGlobalManager $ \ manager ->
+      Client.httpLbs request manager
+
+    when (Client.responseStatus innerResponse /= status204) $
+      left ("HTTP DELETE request failed with status: " ++ show (Client.responseStatus innerResponse))
+
+instance HasDocs Delete where
+  docsFor Proxy (endpoint, action) =
+    single endpoint' action'
+
+    where endpoint' = endpoint & method .~ DocDELETE
+
+          action' = action & response.respBody .~ Nothing
+                           & response.respStatus .~ 204

src/Servant/Docs.hs

@@ -398,6 +398,6 @@ printMarkdown = imapM_ printEndpoint
           putStrLn $ ""
           putStrLn $ " - Status code " ++ show (resp ^. respStatus)
           resp ^. respBody &
-            maybe (putStrLn " - No response body")
+            maybe (putStrLn " - No response body\n")
                   (\b -> putStrLn " - Response body as below." >> jsonStr b)