add client, server and docs support for PUT

This commit is contained in:
Alp Mestanogullari 2014-10-28 09:17:28 +01:00
parent 97d4133eb1
commit 1181eb8d5e
3 changed files with 68 additions and 1 deletions

View file

@ -25,6 +25,7 @@ library
Servant.API.Get Servant.API.Get
Servant.API.GetParam Servant.API.GetParam
Servant.API.Post Servant.API.Post
Servant.API.Put
Servant.API.Raw Servant.API.Raw
Servant.API.RQBody Servant.API.RQBody
Servant.API.Sub Servant.API.Sub

View file

@ -4,6 +4,7 @@ module Servant.API
, module Servant.API.Get , module Servant.API.Get
, module Servant.API.GetParam , module Servant.API.GetParam
, module Servant.API.Post , module Servant.API.Post
, module Servant.API.Put
, module Servant.API.RQBody , module Servant.API.RQBody
, module Servant.API.Sub , module Servant.API.Sub
, module Servant.API.Union , module Servant.API.Union
@ -14,6 +15,7 @@ import Servant.API.Delete
import Servant.API.Get import Servant.API.Get
import Servant.API.GetParam import Servant.API.GetParam
import Servant.API.Post import Servant.API.Post
import Servant.API.Put
import Servant.API.RQBody import Servant.API.RQBody
import Servant.API.Sub import Servant.API.Sub
import Servant.API.Union import Servant.API.Union

64
src/Servant/API/Put.hs Normal file
View file

@ -0,0 +1,64 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.API.Put where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.Aeson
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 PUT requests.
data Put a
instance ToJSON a => HasServer (Put a) where
type Server (Put a) = EitherT (Int, String) IO a
route Proxy action _globalPathInfo request respond
| null (pathInfo request) && requestMethod request == methodPut = do
e <- runEitherT action
respond $ Just $ case e of
Right out ->
responseLBS ok200 [("Content-Type", "application/json")] (encode out)
Left (status, message) ->
responseLBS (mkStatus status (cs message)) [] (cs message)
| otherwise = respond Nothing
instance FromJSON a => HasClient (Put a) where
type Client (Put a) = URI -> EitherT String IO a
clientWithRoute Proxy req uri = do
partialRequest <- liftIO $ reqToRequest req uri
let request = partialRequest { Client.method = methodPut
}
innerResponse <- liftIO . __withGlobalManager $ \ manager ->
Client.httpLbs request manager
when (Client.responseStatus innerResponse /= ok200) $
left ("HTTP PUT request failed with status: " ++ show (Client.responseStatus innerResponse))
maybe (left "HTTP PUT request returned invalid json") return $
decode' (Client.responseBody innerResponse)
instance ToSample a => HasDocs (Put a) where
docsFor Proxy (endpoint, action) =
single endpoint' action'
where endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ toSample p
& response.respStatus .~ 200
p = Proxy :: Proxy a