git.iko.soy/typeable/servant-reflex
on master help sign in
Merge pull request #28 from imalsogreg/error-messages

Feed response error messages through to ResponseFailure

commit8a1e017e8f71f1cd24589f0dabf1986ba295aa72 authorGreg Hale <ImAlsoGreg@gmail.com> dateThu 2 Mar 2017, 11:07 (10 years ago) parentfe98db806c5c50
2 files changed+36−10
compare with master
unifiedsplit
src/Servant/Common/Req.hs+33−9 testserver/Main.hs+3−1
src/Servant/Common/Req.hs+33−9
@@ -10,9 +10,10 @@ module Servant.Common.Req where
1010
1111-------------------------------------------------------------------------------
1212import Control.Applicative (liftA2, liftA3)
13+import Data.Bifunctor (first)
1314import qualified Data.ByteString.Lazy.Char8 as BL
1415import qualified Data.Map as Map
15−import Data.Maybe (catMaybes)
16+import Data.Maybe (catMaybes, fromMaybe)
1617import Data.Monoid ((<>))
1718import Data.Proxy (Proxy(..))
1819import Data.Text (Text)
@@ -214,6 +215,8 @@ type XhrPayload = T.Text
214215bytesToPayload :: BL.ByteString -> XhrPayload
215216bytesToPayload = TE.decodeUtf8 . BL.toStrict
216217
218+
219+------------------------------------------------------------------------------
217220performRequestNoBody :: forall t m .(SupportsServantReflex t m)
218221 => Text
219222 -> Req t
@@ -221,22 +224,43 @@ performRequestNoBody :: forall t m .(SupportsServantReflex t m)
221224 -> Event t () -> m (Event t (ReqResult NoContent))
222225performRequestNoBody reqMeth req reqHost trigger = do
223226 (resp, badReq) <- performRequest reqMeth req reqHost trigger
224− return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]
227+ let decodeResp = const $ Right NoContent
228+ return $ leftmost [ fmap (evalRequest decodeResp) resp,
229+ fmap RequestFailure badReq]
225230
226231
232+------------------------------------------------------------------------------
227233performRequestCT :: (SupportsServantReflex t m,
228234 MimeUnrender ct a)
229235 => Proxy ct -> Text -> Req t -> Dynamic t BaseUrl
230236 -> Event t () -> m (Event t (ReqResult a))
231237performRequestCT ct reqMeth req reqHost trigger = do
232238 (resp, badReq) <- performRequest reqMeth req reqHost trigger
233− let decodes = ffor resp $ \xhr ->
234− ((mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)
235− =<< note "No body text" (_xhrResponse_responseText xhr), xhr)
236− reqs = ffor decodes $ \case
237− (Right a, r) -> ResponseSuccess a r
238− (Left e, r) -> ResponseFailure (T.pack e) r
239− return $ leftmost [reqs, fmap RequestFailure badReq]
239+ let decodeResp x = first T.pack .
240+ mimeUnrender ct .
241+ BL.fromStrict .
242+ TE.encodeUtf8 =<< note "No body text"
243+ (_xhrResponse_responseText x)
244+
245+ return $ leftmost [fmap (evalRequest decodeResp) resp,
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+
240264
241265note :: e -> Maybe a -> Either e a
242266note e = maybe (Left e) Right
testserver/Main.hs+3−1
@@ -60,7 +60,9 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|>
6060 | otherwise = T.intercalate ", " (L.init greetings)
6161 <> ", and " <> L.last greetings <> ", "
6262 return . modifier $ greetPart <> n
63− dbl x = return $ x * 2
63+ dbl x = if x `elem` [4,13]
64+ then throwError $ err500 { errBody = "No unlucky numbers please" }
65+ else return $ x * 2
6466 multi = return . bool "Box unchecked" "Box Checked"
6567 qna q = do
6668 liftIO $ do