git.iko.soy/servant
on d85231d help sign in
servant/src/Servant/API/Post.hs
51 lines 1.7 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.
20data Post a
22instance ToJSON a => HasServer (Post a) where
23 type Server (Post a) = EitherT (Int, String) IO a
25 route Proxy action _globalPathInfo request respond
26 | null (pathInfo request) && requestMethod request == methodPost = do
27 e <- runEitherT action
28 respond $ Just $ case e of
29 Right out ->
30 responseLBS status201 [("Content-Type", "application/json")] (encode out)
31 Left (status, message) ->
32 responseLBS (mkStatus status (cs message)) [] (cs message)
33 | otherwise = respond Nothing
35instance FromJSON a => HasClient (Post a) where
36 type Client (Post a) = URI -> EitherT String IO a
38 clientWithRoute Proxy req uri = do
39 partialRequest <- liftIO $ reqToRequest req uri
41 let request = partialRequest { Client.method = methodPost
42 }
44 innerResponse <- liftIO . __withGlobalManager $ \ manager ->
45 Client.httpLbs request manager
47 when (Client.responseStatus innerResponse /= status201) $
48 left ("HTTP POST request failed with status: " ++ show (Client.responseStatus innerResponse))
50 maybe (left "HTTP POST request returned invalid json") return $
51 decode' (Client.responseBody innerResponse)