master...f9228ea · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on f9228ea help sign in

servant-reflex.cabal+5

since splitsnapshots

unifiedsplit

@@ -27,6 +27,7 @@ library

27 hs-source-dirs: src

28 build-depends:

29 base >= 4.8 && < 4.10,

30+ aeson >= 0.11.2 && < 0.12,

30 bytestring >= 0.10 && < 0.11,

31 bytestring >= 0.10 && < 0.11,

31 case-insensitive >= 1.2.0.4 && < 1.3,

32 case-insensitive >= 1.2.0.4 && < 1.3,

32 containers >= 0.5.6 && < 0.6,

33 containers >= 0.5.6 && < 0.6,

@@ -45,6 +46,10 @@ library

45 text >= 1.2 && < 1.3,

46 text >= 1.2 && < 1.3,

46 transformers >= 0.4 && < 0.6

47 transformers >= 0.4 && < 0.6

49+ if impl(ghcjs)

50+ build-depends:

51+ ghcjs-base >= 0.2 && < 0.3

52+

48 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

53 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

50 default-language: Haskell2010

55 default-language: Haskell2010

src/Servant/Common/Req.hs+52−3

@@ -14,7 +14,10 @@ import Control.Concurrent

14import Control.Applicative (liftA2, liftA3)

15import Control.Monad (join)

16import Control.Monad.IO.Class (MonadIO, liftIO)

17+import Data.Aeson

18+import qualified Data.Aeson as Aeson

17import Data.Bifunctor (first)

19import Data.Bifunctor (first)

20+import qualified Data.ByteString.Char8 as BS

18import qualified Data.ByteString.Lazy.Char8 as BL

21import qualified Data.ByteString.Lazy.Char8 as BL

19import qualified Data.Map as Map

22import qualified Data.Map as Map

20import Data.Maybe (catMaybes, fromMaybe)

23import Data.Maybe (catMaybes, fromMaybe)

@@ -25,15 +28,27 @@ import Data.Text (Text)

25import qualified Data.Text as T

28import qualified Data.Text as T

26import qualified Data.Text.Encoding as TE

29import qualified Data.Text.Encoding as TE

27import Data.Traversable (forM)

30import Data.Traversable (forM)

31+import Data.Typeable

28import Reflex.Dom hiding (tag)

32import Reflex.Dom hiding (tag)

29import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

33import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

30 SupportsServantReflex)

34 SupportsServantReflex)

31−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))

35+import Servant.API.ContentTypes (JSON, MimeUnrender(..),

36+ NoContent(..))

32import Web.HttpApiData (ToHttpApiData(..))

37import Web.HttpApiData (ToHttpApiData(..))

33-------------------------------------------------------------------------------

38-------------------------------------------------------------------------------

34import Servant.API.BasicAuth

39import Servant.API.BasicAuth

42+#ifdef ghcjs_HOST_OS

43+import Control.Exception

44+import System.IO.Unsafe (unsafePerformIO)

45+import GHCJS.Buffer (create, fromByteString, getArrayBuffer)

46+import GHCJS.Types (JSVal, jsval)

47+import GHCJS.Marshal (FromJSVal(..), fromJSVal)

48+import GHCJS.Marshal.Pure (pToJSVal)

49+#endif

50+

51+

37------------------------------------------------------------------------------

52------------------------------------------------------------------------------

38-- | The result of a request event

53-- | The result of a request event

39data ReqResult tag a

54data ReqResult tag a

@@ -369,6 +384,40 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do

369 )

384 )

370 resps

385 resps

371

386

387+mimeUnrender' :: (MimeUnrender ct a, Typeable ct, FromJSON a) => Proxy ct -> BS.ByteString -> Either String a

388+mimeUnrender' p bs

389+ | cantRawJson = mimeUnrender p (BL.fromStrict bs)

390+ | otherwise = note "Raw JSON decode failure" $ rawDecode bs

391+ where

392+ cantRawJson = typeOf (Proxy :: Proxy JSON) /= typeOf p

393+

394+-- copied from http://lpaste.net/6122658287709061120

395+#ifdef ghcjs_HOST_OS

396+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal

397+foreign import javascript unsafe "JSON['parse']($1)" js_jsonParse :: JSVal -> JSVal

398+rawDecode :: (FromJSON a) => BS.ByteString -> Maybe a

399+rawDecode bs = do

400+ -- Below copied from Reflex.Dom.WebSocket.Foreign

401+ -- let (b, off, len) = fromByteString bs

402+ -- -- x = return $ js_dataView off len $ jsval $ getArrayBuffer b :: _

403+ -- jsv :: JSVal <- if BS.length bs == 0

404+ -- then undefined -- jsval . getArrayBuffer <$> create 0

405+ -- else undefined -- return $ js_dataView off len $ jsval $ getArrayBuffer b

406+

407+ let jsv = _ bs

408+ -- TODO pFromJSVal to avoid unsafePerformIO

409+ let res = unsafePerformIO $ try $ fromJSVal $ js_jsonParse jsv

410+ case res of

411+ Left (_e :: SomeException) -> Nothing

412+ Right (v :: (Maybe Aeson.Value)) -> maybe Nothing go v

413+ where

414+ go v = case Aeson.fromJSON v of

415+ Aeson.Success a -> Just a

416+ _ -> Nothing

417+#else

418+rawDecode :: FromJSON a => BS.ByteString -> Maybe a

419+rawDecode = decode . BL.fromStrict

420+#endif

372

421

373performRequestsNoBody

422performRequestsNoBody

374 :: (SupportsServantReflex t m,

423 :: (SupportsServantReflex t m,

@@ -391,7 +440,7 @@ evalResponse

391 :: (XhrResponse -> Either Text a)

440 :: (XhrResponse -> Either Text a)

392 -> (tag, XhrResponse)

441 -> (tag, XhrResponse)

393 -> ReqResult tag a

442 -> ReqResult tag a

394−evalResponse decode (tag, xhr) =

443+evalResponse decodeFun (tag, xhr) =

395 let okStatus = _xhrResponse_status xhr < 400

444 let okStatus = _xhrResponse_status xhr < 400

396 errMsg = fromMaybe

445 errMsg = fromMaybe

397 ("Empty response with error code " <>

446 ("Empty response with error code " <>

@@ -401,7 +450,7 @@ evalResponse decode (tag, xhr) =

401 then either

450 then either

402 (\e -> ResponseFailure tag e xhr)

451 (\e -> ResponseFailure tag e xhr)

403 (\v -> ResponseSuccess tag v xhr)

452 (\v -> ResponseSuccess tag v xhr)

404− (decode xhr)

453+ (decodeFun xhr)

405 else ResponseFailure tag errMsg xhr

454 else ResponseFailure tag errMsg xhr

406 in respPayld

455 in respPayld

407

456