git.iko.soy/servant
on c393afa help sign in
servant/src/Servant/API/Post.hs
51 lines 1.6 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 request
26 | null (pathInfo request) && requestMethod request == methodPost = do
27 e <- runEitherT action
28 return $ 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 = return 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)