git.iko.soy/typeable/servant-reflex
on master help sign in
Actually use rawDecode
commit4ea45c46bfb81818ab3ea53e272819bf110c23fc authorGreg Hale <imalsogreg@gmail.com> dateFri 31 Mar 2017, 17:38 (10 years ago) parent629fbac
1 file changed+24−23
src/Servant/Common/Req.hs+24−23
src/Servant/Common/Req.hs+24−23
@@ -374,9 +374,8 @@ performRequestsCT
374374performRequestsCT ct reqMeth reqs reqHost trigger = do
375375 resps <- performRequests reqMeth reqs reqHost trigger
376376 let decodeResp x = first T.pack .
377− mimeUnrender ct .
378− BL.fromStrict .
379− TE.encodeUtf8 =<< note "No body text"
377+ mimeUnrender ct
378+ =<< note "No body text"
380379 (_xhrResponse_responseText x)
381380 return $ fmap
382381 (\(t,rs) -> ffor rs $ \r -> case r of
@@ -400,21 +399,24 @@ foreign import javascript safe "new DataView($3,$1,$2)"
400399foreign import javascript unsafe "console.log($1); $r = JSON['parse']($1);"
401400 js_jsonParse :: JSVal -> JSVal
402401
403−rawDecode :: (FromJSON a) => BS.ByteString -> Maybe a
402+rawDecode :: (FromJSON a) => T.Text -> Maybe a
404403rawDecode bs = do
405404 -- Below copied from Reflex.Dom.WebSocket.Foreign
406405 -- tmp <- Just $ unsafePerformIO $ putStrLn ("bs: " ++ BS.unpack bs)
407406 -- error ("bs: " ++ BS.unpack bs)
408− let (b, off, len) = fromByteString bs
407+ -- let (b, off, len) = fromByteString bs
409408 -- x = return $ js_dataView off len $ jsval $ getArrayBuffer b :: _
410409 -- tmp <- error (BS.unpack bs)
411− let jsv = if BS.length bs == 0
412− then error "ZERO!!" -- unsafePerformIO $ jsval . getArrayBuffer <$> create 0
413− else js_dataView off len $ jsval $ getArrayBuffer b
410+
411+ -- let jsv = if BS.length bs == 0
412+ -- then unsafePerformIO $ jsval . getArrayBuffer <$> create 0
413+ -- else js_dataView off len $ jsval $ getArrayBuffer b
414+
415+ let jsv = T.textToJSString bs
414416
415417 -- let jsv = _ bs
416418 -- TODO pFromJSVal to avoid unsafePerformIO
417− let res = unsafePerformIO $ try $ aesonFromJSVal $ js_jsonParse jsv
419+ let res = unsafePerformIO $ try $ aesonFromJSVal $ js_jsonParse $ jsval jsv
418420 case res of
419421 Left (_e :: SomeException) -> Nothing
420422 Right (v :: (Maybe Aeson.Value)) -> maybe Nothing go v
@@ -436,8 +438,7 @@ aesonFromJSVal r = do
436438 JSONFloat -> liftM (A.Number . (fromFloatDigits :: Double -> Scientific))
437439 <$> fromJSVal r
438440 JSONBool -> liftM A.Bool <$> fromJSVal r
439− JSONString -> liftM (A.String . ("TEST" <>)) <$> fromJSVal r
440− -- JSONArray -> liftM (A.Array . V.fromList) <$> (fromJSVal r :: _)
441+ JSONString -> liftM A.String <$> fromJSVal r
441442 JSONArray -> liftM (A.Array . V.fromList) <$>
442443 runMaybeT (traverse (MaybeT . aesonFromJSVal) =<<
443444 (MaybeT (fromJSVal r)))
@@ -447,7 +448,7 @@ aesonFromJSVal r = do
447448 propVals <- forM props $ \p -> do
448449 v <- MaybeT (aesonFromJSVal =<< OI.getProp p (OI.Object r))
449450 return (T.textFromJSString p, v)
450− return (A.Object (H.fromList propVals <> H.fromList [("extratest", A.Null)]))
451+ return (A.Object (H.fromList propVals))
451452{-# INLINE aesonFromJSVal #-}
452453
453454#else
@@ -525,11 +526,11 @@ eitherDecodeLenient input =
525526
526527-- | `eitherDecode`
527528instance FromJSON a => MimeUnrender JSON a where
528− mimeUnrender _ bs =
529+ mimeUnrender _ t =
529530#ifdef ghcjs_HOST_OS
530− note "Raw JSON decode failure" $ rawDecode (BL.toStrict bs)
531+ note "Raw JSON decode failure" $ rawDecode t -- (BL.toStrict bs)
531532#else
532− eitherDecodeLenient bs
533+ eitherDecodeLenient (BL.fromStrict $ TE.encodeUtf8 t)
533534#endif
534535
535536-- -- | @urlDecodeAsForm@
@@ -540,31 +541,31 @@ instance FromJSON a => MimeUnrender JSON a where
540541
541542-- | @left show . TextL.decodeUtf8'@
542543instance MimeUnrender PlainText TextL.Text where
543− mimeUnrender _ = left show . TextL.decodeUtf8'
544+ mimeUnrender _ = return . TextL.fromStrict
544545
545546-- | @left show . TextS.decodeUtf8' . toStrict@
546547instance MimeUnrender PlainText T.Text where
547− mimeUnrender _ = left show . TE.decodeUtf8' . BL.toStrict
548+ mimeUnrender _ = return
548549
549550-- | @Right . BC.unpack@
550551instance MimeUnrender PlainText String where
551− mimeUnrender _ = Right . BL.unpack
552+ mimeUnrender _ = Right . T.unpack
552553
553554-- | @Right . id@
554555instance MimeUnrender OctetStream BL.ByteString where
555− mimeUnrender _ = Right . id
556+ mimeUnrender _ = return . TextL.encodeUtf8 . TextL.fromStrict
556557
557558-- | @Right . toStrict@
558559instance MimeUnrender OctetStream BS.ByteString where
559− mimeUnrender _ = Right . BL.toStrict
560+ mimeUnrender _ = Right . TE.encodeUtf8
560561
561562class Accept ctype => MimeUnrender ctype a where
562− mimeUnrender :: Proxy ctype -> BL.ByteString -> Either String a
563+ mimeUnrender :: Proxy ctype -> T.Text -> Either String a
563564
564565class AllCTUnrender (list :: [*]) a where
565566 handleCTypeH :: Proxy list
566567 -> BL.ByteString -- Content-Type header
567− -> BL.ByteString -- Request body
568+ -> T.Text -- Request body
568569 -> Maybe (Either String a)
569570
570571instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
@@ -581,7 +582,7 @@ canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h
581582--------------------------------------------------------------------------
582583class (AllMime list) => AllMimeUnrender (list :: [*]) a where
583584 allMimeUnrender :: Proxy list
584− -> BL.ByteString
585+ -> T.Text
585586 -> [(M.MediaType, Either String a)]
586587
587588instance AllMimeUnrender '[] a where