git.iko.soy/servant
on 9ade9a4 help sign in
servant/src/Servant/API/Put.hs
67 lines 2.1 kB history raw
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4module Servant.API.Put where
6import Control.Monad
7import Control.Monad.IO.Class
8import Control.Monad.Trans.Either
9import Data.Aeson
10import Data.Proxy
11import Data.String.Conversions
12import Network.HTTP.Types
13import Network.URI
14import Network.Wai
15import Servant.Client
16import Servant.Docs
17import Servant.Server
19import qualified Network.HTTP.Client as Client
21-- | Endpoint for PUT requests.
22data Put a
24instance ToJSON a => HasServer (Put a) where
25 type Server (Put a) = EitherT (Int, String) IO a
27 route Proxy action request respond
28 | null (pathInfo request) && requestMethod request == methodPut = do
29 e <- runEitherT action
30 respond . succeedWith $ 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 | null (pathInfo request) && requestMethod request /= methodPut =
36 respond $ failWith WrongMethod
38 | otherwise = respond $ failWith NotFound
40instance FromJSON a => HasClient (Put a) where
41 type Client (Put a) = URI -> EitherT String IO a
43 clientWithRoute Proxy req uri = do
44 partialRequest <- liftIO $ reqToRequest req uri
46 let request = partialRequest { Client.method = methodPut
47 }
49 innerResponse <- liftIO . __withGlobalManager $ \ manager ->
50 Client.httpLbs request manager
52 when (Client.responseStatus innerResponse /= ok200) $
53 left ("HTTP PUT request failed with status: " ++ show (Client.responseStatus innerResponse))
55 maybe (left "HTTP PUT request returned invalid json") return $
56 decode' (Client.responseBody innerResponse)
58instance ToSample a => HasDocs (Put a) where
59 docsFor Proxy (endpoint, action) =
60 single endpoint' action'
62 where endpoint' = endpoint & method .~ DocPUT
64 action' = action & response.respBody .~ toSample p
65 & response.respStatus .~ 200
67 p = Proxy :: Proxy a