eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Implement new constructors for GHCJS.

Browse source 
Streaming is not actually performed - instead the whole object is
    held in memory.
This commit is contained in:
Julian K. Arni 2018-03-19 10:46:26 +01:00
parent 2456dcb8f5
commit c02ca1b6e1
1 changed files with 31 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs
View file

@ -15,7 +15,6 @@
module Servant.Client.Internal.XhrClient where module Servant.Client.Internal.XhrClient where
import Control.Arrow import Control.Arrow
import Data.ByteString.Builder (toLazyByteString)
import Control.Concurrent import Control.Concurrent
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
@ -25,11 +24,13 @@ import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Data.CaseInsensitive import Data.CaseInsensitive
import Data.Char import Data.Char
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Functor.Alt (Alt (..)) import Data.Functor.Alt (Alt (..))
import Data.IORef (modifyIORef, newIORef, readIORef)
import Data.Proxy (Proxy (..)) import Data.Proxy (Proxy (..))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.String.Conversions import Data.String.Conversions
@ -39,8 +40,8 @@ import GHCJS.Foreign.Callback
import GHCJS.Prim import GHCJS.Prim
import GHCJS.Types import GHCJS.Types
import JavaScript.Web.Location import JavaScript.Web.Location
import Network.HTTP.Types
import Network.HTTP.Media (renderHeader) import Network.HTTP.Media (renderHeader)
import Network.HTTP.Types
import Servant.Client.Core import Servant.Client.Core
newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
@ -152,7 +153,8 @@ performXhr xhr burl request = do
openXhr xhr (cs $ requestMethod request) (toUrl burl request) True openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
setHeaders xhr request setHeaders xhr request
sendXhr xhr (toBody request) body <- toBody request
sendXhr xhr body
takeMVar waiter takeMVar waiter
freeStablePtr s freeStablePtr s
@ -226,11 +228,31 @@ foreign import javascript unsafe "$1.send()"
foreign import javascript unsafe "$1.send($2)" foreign import javascript unsafe "$1.send($2)"
js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO () js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
toBody :: Request -> Maybe String toBody :: Request -> IO (Maybe String)
toBody request = case requestBody request of toBody request = case requestBody request of
Nothing -> Nothing Nothing -> return Nothing
Just (RequestBodyLBS "", _) -> Nothing Just (a, _) -> go a
Just (RequestBodyLBS x, _) -> Just $ cs x
where
go :: RequestBody -> IO (Maybe String)
go x = case x of
RequestBodyLBS x -> return $ mBody x
RequestBodyBS x -> return $ mBody x
RequestBodyBuilder _ x -> return $ mBody $ toLazyByteString x
RequestBodyStream _ x -> mBody <$> readBody x
RequestBodyStreamChunked x -> mBody <$> readBody x
RequestBodyIO x -> x >>= go
mBody :: ConvertibleStrings a String => a -> Maybe String
mBody x = let y = cs x in if y == "" then Nothing else Just y
readBody writer = do
m <- newIORef mempty
_ <- writer (\bsAct -> do
bs <- bsAct
modifyIORef m (<> bs))
readIORef m
-- * inspecting the xhr response -- * inspecting the xhr response