git.iko.soy/typeable/servant-reflex
on master help sign in
Feed response error messages through to ResponseFailure
06c5c50Greg Hale
src/Servant/Common/Req.hs+33−9
compare with master
unifiedsplit
@@ -10,9 +10,10 @@ module Servant.Common.Req where
10
10
11-------------------------------------------------------------------------------
11-------------------------------------------------------------------------------
12import Control.Applicative (liftA2, liftA3)
12import Control.Applicative (liftA2, liftA3)
13+import Data.Bifunctor (first)
13import qualified Data.ByteString.Lazy.Char8 as BL
14import qualified Data.ByteString.Lazy.Char8 as BL
14import qualified Data.Map as Map
15import qualified Data.Map as Map
15−import Data.Maybe (catMaybes)
16+import Data.Maybe (catMaybes, fromMaybe)
16import Data.Monoid ((<>))
17import Data.Monoid ((<>))
17import Data.Proxy (Proxy(..))
18import Data.Proxy (Proxy(..))
18import Data.Text (Text)
19import Data.Text (Text)
@@ -214,6 +215,8 @@ type XhrPayload = T.Text
214bytesToPayload :: BL.ByteString -> XhrPayload
215bytesToPayload :: BL.ByteString -> XhrPayload
215bytesToPayload = TE.decodeUtf8 . BL.toStrict
216bytesToPayload = TE.decodeUtf8 . BL.toStrict
216
217
218+
219+------------------------------------------------------------------------------
217performRequestNoBody :: forall t m .(SupportsServantReflex t m)
220performRequestNoBody :: forall t m .(SupportsServantReflex t m)
218 => Text
221 => Text
219 -> Req t
222 -> Req t
@@ -221,22 +224,43 @@ performRequestNoBody :: forall t m .(SupportsServantReflex t m)
221 -> Event t () -> m (Event t (ReqResult NoContent))
224 -> Event t () -> m (Event t (ReqResult NoContent))
222performRequestNoBody reqMeth req reqHost trigger = do
225performRequestNoBody reqMeth req reqHost trigger = do
223 (resp, badReq) <- performRequest reqMeth req reqHost trigger
226 (resp, badReq) <- performRequest reqMeth req reqHost trigger
227+ let decodeResp = const $ Right NoContent
228+ return $ leftmost [ fmap (evalRequest decodeResp) resp,
224− return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]
229+ fmap RequestFailure badReq]
225
230
226
231
232+------------------------------------------------------------------------------
227performRequestCT :: (SupportsServantReflex t m,
233performRequestCT :: (SupportsServantReflex t m,
228 MimeUnrender ct a)
234 MimeUnrender ct a)
229 => Proxy ct -> Text -> Req t -> Dynamic t BaseUrl
235 => Proxy ct -> Text -> Req t -> Dynamic t BaseUrl
230 -> Event t () -> m (Event t (ReqResult a))
236 -> Event t () -> m (Event t (ReqResult a))
231performRequestCT ct reqMeth req reqHost trigger = do
237performRequestCT ct reqMeth req reqHost trigger = do
232 (resp, badReq) <- performRequest reqMeth req reqHost trigger
238 (resp, badReq) <- performRequest reqMeth req reqHost trigger
233− let decodes = ffor resp $ \xhr ->
239+ let decodeResp x = first T.pack .
234− ((mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)
240+ mimeUnrender ct .
241+ BL.fromStrict .
242+ TE.encodeUtf8 =<< note "No body text"
235− =<< note "No body text" (_xhrResponse_responseText xhr), xhr)
243+ (_xhrResponse_responseText x)
236− reqs = ffor decodes $ \case
244+
237− (Right a, r) -> ResponseSuccess a r
245+ return $ leftmost [fmap (evalRequest decodeResp) resp,
238− (Left e, r) -> ResponseFailure (T.pack e) r
239− return $ leftmost [reqs, fmap RequestFailure badReq]
246+ fmap RequestFailure badReq]
247+
248+
249+------------------------------------------------------------------------------
250+evalRequest :: (XhrResponse -> Either Text a) -> XhrResponse -> ReqResult a
251+evalRequest decode xhr =
252+ let okStatus = _xhrResponse_status xhr < 400
253+ errMsg = fromMaybe
254+ ("Empty response with error code " <>
255+ T.pack (show $ _xhrResponse_status xhr))
256+ (_xhrResponse_responseText xhr)
257+ respPayld = if okStatus
258+ then either (flip ResponseFailure xhr)
259+ (flip ResponseSuccess xhr) (decode xhr)
260+ else ResponseFailure errMsg xhr
261+ in respPayld
262+
263+
240
264
241note :: e -> Maybe a -> Either e a
265note :: e -> Maybe a -> Either e a
242note e = maybe (Left e) Right
266note e = maybe (Left e) Right
testserver/Main.hs+3−1
@@ -60,7 +60,9 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|>
60 | otherwise = T.intercalate ", " (L.init greetings)
60 | otherwise = T.intercalate ", " (L.init greetings)
61 <> ", and " <> L.last greetings <> ", "
61 <> ", and " <> L.last greetings <> ", "
62 return . modifier $ greetPart <> n
62 return . modifier $ greetPart <> n
63+ dbl x = if x `elem` [4,13]
64+ then throwError $ err500 { errBody = "No unlucky numbers please" }
63− dbl x = return $ x * 2
65+ else return $ x * 2
64 multi = return . bool "Box unchecked" "Box Checked"
66 multi = return . bool "Box unchecked" "Box Checked"
65 qna q = do
67 qna q = do
66 liftIO $ do
68 liftIO $ do