@@ -0,0 +1,64 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+module Servant.API.Put where
5+
6+import Control.Monad
7+import Control.Monad.IO.Class
8+import Control.Monad.Trans.Either
9+import Data.Aeson
10+import Data.Proxy
11+import Data.String.Conversions
12+import Network.HTTP.Types
13+import Network.URI
14+import Network.Wai
15+import Servant.Client
16+import Servant.Docs
17+import Servant.Server
18+
19+import qualified Network.HTTP.Client as Client
20+
21+-- | Endpoint for PUT requests.
22+data Put a
23+
24+instance ToJSON a => HasServer (Put a) where
25+ type Server (Put a) = EitherT (Int, String) IO a
26+
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
31+ Right out ->
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
36+
37+instance FromJSON a => HasClient (Put a) where
38+ type Client (Put a) = URI -> EitherT String IO a
39+
40+ clientWithRoute Proxy req uri = do
41+ partialRequest <- liftIO $ reqToRequest req uri
42+
43+ let request = partialRequest { Client.method = methodPut
44+ }
45+
46+ innerResponse <- liftIO . __withGlobalManager $ \ manager ->
47+ Client.httpLbs request manager
48+
49+ when (Client.responseStatus innerResponse /= ok200) $
50+ left ("HTTP PUT request failed with status: " ++ show (Client.responseStatus innerResponse))
51+
52+ maybe (left "HTTP PUT request returned invalid json") return $
53+ decode' (Client.responseBody innerResponse)
54+
55+instance ToSample a => HasDocs (Put a) where
56+ docsFor Proxy (endpoint, action) =
57+ single endpoint' action'
58+
59+ where endpoint' = endpoint & method .~ DocPUT
60+
61+ action' = action & response.respBody .~ toSample p
62+ & response.respStatus .~ 200
63+
64+ p = Proxy :: Proxy a