git.iko.soy/servant
on f37e39b help sign in
servant/src/Servant/API/Post.hs
53 lines 1.8 kB history raw
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Servant.API.Post where
5import Control.Monad
6import Control.Monad.IO.Class
7import Control.Monad.Trans.Either
8import Data.Aeson
9import Data.Proxy
10import Data.String.Conversions
11import Network.HTTP.Types
12import Network.URI
13import Network.Wai
14import Servant.Client
15import Servant.Server
17import qualified Network.HTTP.Client as Client
19-- | Endpoint for POST requests. The type variable represents the type of the
20-- response body (not the request body, use 'Servant.API.RQBody.RQBody' for
21-- that).
22data Post a
24instance ToJSON a => HasServer (Post a) where
25 type Server (Post a) = EitherT (Int, String) IO a
27 route Proxy action _globalPathInfo request respond
28 | null (pathInfo request) && requestMethod request == methodPost = do
29 e <- runEitherT action
30 respond $ Just $ case e of
31 Right out ->
32 responseLBS status201 [("Content-Type", "application/json")] (encode out)
33 Left (status, message) ->
34 responseLBS (mkStatus status (cs message)) [] (cs message)
35 | otherwise = respond Nothing
37instance FromJSON a => HasClient (Post a) where
38 type Client (Post a) = URI -> EitherT String IO a
40 clientWithRoute Proxy req uri = do
41 partialRequest <- liftIO $ reqToRequest req uri
43 let request = partialRequest { Client.method = methodPost
44 }
46 innerResponse <- liftIO . __withGlobalManager $ \ manager ->
47 Client.httpLbs request manager
49 when (Client.responseStatus innerResponse /= status201) $
50 left ("HTTP POST request failed with status: " ++ show (Client.responseStatus innerResponse))
52 maybe (left "HTTP POST request returned invalid json") return $
53 decode' (Client.responseBody innerResponse)