@@ -0,0 +1,64 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+module Servant.API.Put where
7+import Control.Monad.IO.Class
8+import Control.Monad.Trans.Either
11+import Data.String.Conversions
12+import Network.HTTP.Types
19+import qualified Network.HTTP.Client as Client
21+-- | Endpoint for PUT requests.
24+instance ToJSON a => HasServer (Put a) where
25+ type Server (Put a) = EitherT (Int, String) IO a
27+ route Proxy action _globalPathInfo request respond
28+ | null (pathInfo request) && requestMethod request == methodPut = do
29+ e <- runEitherT action
30+ respond $ Just $ case e of
32+ responseLBS ok200 [("Content-Type", "application/json")] (encode out)
33+ Left (status, message) ->
34+ responseLBS (mkStatus status (cs message)) [] (cs message)
35+ | otherwise = respond Nothing
37+instance FromJSON a => HasClient (Put a) where
38+ type Client (Put a) = URI -> EitherT String IO a
40+ clientWithRoute Proxy req uri = do
41+ partialRequest <- liftIO $ reqToRequest req uri
43+ let request = partialRequest { Client.method = methodPut
46+ innerResponse <- liftIO . __withGlobalManager $ \ manager ->
47+ Client.httpLbs request manager
49+ when (Client.responseStatus innerResponse /= ok200) $
50+ left ("HTTP PUT request failed with status: " ++ show (Client.responseStatus innerResponse))
52+ maybe (left "HTTP PUT request returned invalid json") return $
53+ decode' (Client.responseBody innerResponse)
55+instance ToSample a => HasDocs (Put a) where
56+ docsFor Proxy (endpoint, action) =
57+ single endpoint' action'
59+ where endpoint' = endpoint & method .~ DocPUT
61+ action' = action & response.respBody .~ toSample p
62+ & response.respStatus .~ 200