@@ -7,6 +7,7 @@ import Control.Monad
77import Control.Monad.IO.Class
88import Control.Monad.Trans.Either
99import Data.Aeson
10+import Data.ByteString.Lazy (ByteString)
1011import Data.Proxy
1112import Data.String.Conversions
1213import GHC.TypeLits
@@ -32,6 +33,9 @@ import System.IO.Unsafe (unsafePerformIO)
3233-- and serves the contained type as JSON.
3334data Get a
3435
36+-- | Endpoint for POST requests.
37+data Post a
38+
3539-- | The contained API (second argument) can be found under @("/" ++ path)@
3640-- (path being the first argument).
3741data (path :: k) :> a = Proxy path :> a
@@ -74,18 +78,33 @@ instance ToJSON result => HasServer (Get result) where
7478 responseLBS (mkStatus status (cs message)) [] (cs message)
7579 | otherwise = return Nothing
7680
81+instance ToJSON a => HasServer (Post a) where
82+ type Server (Post a) = EitherT (Int, String) IO a
83+
84+ route Proxy action request
85+ | null (pathInfo request) && requestMethod request == methodPost = do
86+ e <- runEitherT action
87+ return $ Just $ case e of
88+ Right out ->
89+ responseLBS status201 [("Content-Type", "application/json")] (encode out)
90+ Left (status, message) ->
91+ responseLBS (mkStatus status (cs message)) [] (cs message)
92+ | otherwise = return Nothing
93+
7794instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
78− type Server (path :> sublayout) = path :> (Server sublayout)
79− route Proxy (path :> subserver) request = case pathInfo request of
95+ type Server (path :> sublayout) = Server sublayout
96+ route Proxy subserver request = case pathInfo request of
8097 (first : rest)
81− | first == cs (symbolVal path)
98+ | first == cs (symbolVal proxyPath)
8299 -> route (Proxy :: Proxy sublayout) subserver request{
83100 pathInfo = rest
84101 }
85102 _ -> return Nothing
86103
104+ where proxyPath = Proxy :: Proxy path
105+
87106instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
88− type Server (a :<|> b) = (Server a :<|> Server b)
107+ type Server (a :<|> b) = Server a :<|> Server b
89108 route Proxy (a :<|> b) request = do
90109 m <- route (Proxy :: Proxy a) a request
91110 case m of
@@ -124,15 +143,37 @@ instance FromJSON result => HasClient (Get result) where
124143 maybe (left "HTTP GET request returned invalid json") return $
125144 decode' (Http.Client.responseBody innerResponse)
126145
146+instance FromJSON a => HasClient (Post a) where
147+ type Client (Post a) = ByteString -> URI -> EitherT String IO a
148+
149+ clientWithRoute Proxy path rqbody uri = do
150+ partialRequest <- liftIO . Http.Client.parseUrl $
151+ show ( nullURI { uriPath = path }
152+ `relativeTo` uri
153+ )
154+
155+ let request = partialRequest
156+ { Http.Client.method = methodPost
157+ , Http.Client.requestBody = Http.Client.RequestBodyLBS rqbody
158+ }
159+
160+ innerResponse <- liftIO . __withGlobalManager $ \ manager ->
161+ Http.Client.httpLbs request manager
162+
163+ when (Http.Client.responseStatus innerResponse /= status201) $
164+ left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
165+
166+ maybe (left "HTTP POST request returned invalid json") return $
167+ decode' (Http.Client.responseBody innerResponse)
168+
127169instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
128− type Client (path :> sublayout) = path :> (Client sublayout)
170+ type Client (path :> sublayout) = Client sublayout
129171 clientWithRoute Proxy path =
130− (Proxy :: Proxy path) :>
131172 clientWithRoute (Proxy :: Proxy sublayout)
132173 (path ++ "/" ++ (symbolVal (Proxy :: Proxy path)))
133174
134175instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
135− type Client (a :<|> b) = (Client a :<|> Client b)
176+ type Client (a :<|> b) = Client a :<|> Client b
136177 clientWithRoute Proxy path =
137178 clientWithRoute (Proxy :: Proxy a) path :<|>
138179 clientWithRoute (Proxy :: Proxy b) path