From 97d4133eb1a1d5ccbe858c96c1b67d3a0048e633 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Tue, 28 Oct 2014 09:14:10 +0100 Subject: [PATCH] add client, server and docs support for the DELETE HTTP method --- example/greet.hs | 13 +++++++-- servant.cabal | 1 + src/Servant.hs | 2 ++ src/Servant/API.hs | 2 ++ src/Servant/API/Delete.hs | 58 +++++++++++++++++++++++++++++++++++++++ src/Servant/Docs.hs | 2 +- 6 files changed, 75 insertions(+), 3 deletions(-) create mode 100644 src/Servant/API/Delete.hs diff --git a/example/greet.hs b/example/greet.hs index 363c67ca..882d582a 100644 --- a/example/greet.hs +++ b/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 diff --git a/servant.cabal b/servant.cabal index 211ac233..86e8c7c6 100644 --- a/servant.cabal +++ b/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 diff --git a/src/Servant.hs b/src/Servant.hs index ac2e4a1e..0ec0da89 100644 --- a/src/Servant.hs +++ b/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 diff --git a/src/Servant/API.hs b/src/Servant/API.hs index c35d845e..9fd1eb9b 100644 --- a/src/Servant/API.hs +++ b/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 diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs new file mode 100644 index 00000000..aaa80b14 --- /dev/null +++ b/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 diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index a52f028d..2d72ea8b 100644 --- a/src/Servant/Docs.hs +++ b/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) \ No newline at end of file