diff --git a/servant.cabal b/servant.cabal index 86e8c7c6..3ccee0c8 100644 --- a/servant.cabal +++ b/servant.cabal @@ -25,6 +25,7 @@ library Servant.API.Get Servant.API.GetParam Servant.API.Post + Servant.API.Put Servant.API.Raw Servant.API.RQBody Servant.API.Sub diff --git a/src/Servant/API.hs b/src/Servant/API.hs index 9fd1eb9b..14ed106e 100644 --- a/src/Servant/API.hs +++ b/src/Servant/API.hs @@ -4,6 +4,7 @@ module Servant.API , module Servant.API.Get , module Servant.API.GetParam , module Servant.API.Post + , module Servant.API.Put , module Servant.API.RQBody , module Servant.API.Sub , module Servant.API.Union @@ -14,6 +15,7 @@ import Servant.API.Delete import Servant.API.Get import Servant.API.GetParam import Servant.API.Post +import Servant.API.Put import Servant.API.RQBody import Servant.API.Sub -import Servant.API.Union \ No newline at end of file +import Servant.API.Union diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs new file mode 100644 index 00000000..7148504a --- /dev/null +++ b/src/Servant/API/Put.hs @@ -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