git.iko.soy/servant
on 14e6a49 help sign in
servant/src/Servant/API/Post.hs
68 lines 2.3 kB history raw
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4module Servant.API.Post 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 POST requests. The type variable represents the type of the
22-- response body (not the request body, use 'Servant.API.RQBody.RQBody' for
23-- that).
24data Post a
26instance ToJSON a => HasServer (Post a) where
27 type Server (Post a) = EitherT (Int, String) IO a
29 route Proxy action request respond
30 | null (pathInfo request) && requestMethod request == methodPost = do
31 e <- runEitherT action
32 respond . succeedWith $ case e of
33 Right out ->
34 responseLBS status201 [("Content-Type", "application/json")] (encode out)
35 Left (status, message) ->
36 responseLBS (mkStatus status (cs message)) [] (cs message)
37 | null (pathInfo request) && requestMethod request /= methodPost =
38 respond $ failWith WrongMethod
39 | otherwise = respond $ failWith NotFound
41instance FromJSON a => HasClient (Post a) where
42 type Client (Post a) = URIAuth -> EitherT String IO a
44 clientWithRoute Proxy req uri = do
45 partialRequest <- liftIO $ reqToRequest req uri
47 let request = partialRequest { Client.method = methodPost
48 }
50 innerResponse <- liftIO . __withGlobalManager $ \ manager ->
51 Client.httpLbs request manager
53 when (Client.responseStatus innerResponse /= status201) $
54 left ("HTTP POST request failed with status: " ++ show (Client.responseStatus innerResponse))
56 maybe (left "HTTP POST request returned invalid json") return $
57 decode' (Client.responseBody innerResponse)
59instance ToSample a => HasDocs (Post a) where
60 docsFor Proxy (endpoint, action) =
61 single endpoint' action'
63 where endpoint' = endpoint & method .~ DocPOST
65 action' = action & response.respBody .~ toSample p
66 & response.respStatus .~ 201
68 p = Proxy :: Proxy a