c02ca1b · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Implement new constructors for GHCJS.

c02ca1bJulian K. Arni9 years ago

servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+31−9

compare with master

unifiedsplit

@@ -15,7 +15,6 @@

15module Servant.Client.Internal.XhrClient where

17import Control.Arrow

18−import Data.ByteString.Builder (toLazyByteString)

19import Control.Concurrent

18import Control.Concurrent

20import Control.Exception

19import Control.Exception

21import Control.Monad

20import Control.Monad

@@ -25,13 +24,15 @@ import Control.Monad.Error.Class (MonadError (..))

25import Control.Monad.Reader

24import Control.Monad.Reader

26import Control.Monad.Trans.Control (MonadBaseControl (..))

25import Control.Monad.Trans.Control (MonadBaseControl (..))

27import Control.Monad.Trans.Except

26import Control.Monad.Trans.Except

27+import Data.ByteString.Builder (toLazyByteString)

28−import qualified Data.ByteString.Char8 as BS

28+import qualified Data.ByteString.Char8 as BS

29import Data.CaseInsensitive

30import Data.Char

31import Data.Foldable (toList)

32import Data.Functor.Alt (Alt (..))

33+import Data.IORef (modifyIORef, newIORef, readIORef)

33import Data.Proxy (Proxy (..))

34import Data.Proxy (Proxy (..))

34−import qualified Data.Sequence as Seq

35+import qualified Data.Sequence as Seq

35import Data.String.Conversions

36import Data.String.Conversions

36import Foreign.StablePtr

37import Foreign.StablePtr

37import GHC.Generics

38import GHC.Generics

@@ -39,8 +40,8 @@ import GHCJS.Foreign.Callback

39import GHCJS.Prim

40import GHCJS.Prim

40import GHCJS.Types

41import GHCJS.Types

41import JavaScript.Web.Location

42import JavaScript.Web.Location

43+import Network.HTTP.Media (renderHeader)

42import Network.HTTP.Types

44import Network.HTTP.Types

43−import Network.HTTP.Media (renderHeader)

44import Servant.Client.Core

45import Servant.Client.Core

46newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal

47newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal

@@ -152,7 +153,8 @@ performXhr xhr burl request = do

152

153

153 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True

154 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True

154 setHeaders xhr request

155 setHeaders xhr request

155− sendXhr xhr (toBody request)

156+ body <- toBody request

157+ sendXhr xhr body

156 takeMVar waiter

158 takeMVar waiter

157

159

158 freeStablePtr s

160 freeStablePtr s

@@ -226,11 +228,31 @@ foreign import javascript unsafe "$1.send()"

226foreign import javascript unsafe "$1.send($2)"

228foreign import javascript unsafe "$1.send($2)"

227 js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()

229 js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()

228

230

229−toBody :: Request -> Maybe String

231+toBody :: Request -> IO (Maybe String)

230toBody request = case requestBody request of

232toBody request = case requestBody request of

231− Nothing -> Nothing

233+ Nothing -> return Nothing

232− Just (RequestBodyLBS "", _) -> Nothing

234+ Just (a, _) -> go a

235+

236+ where

237+ go :: RequestBody -> IO (Maybe String)

238+ go x = case x of

233− Just (RequestBodyLBS x, _) -> Just $ cs x

239+ RequestBodyLBS x -> return $ mBody x

240+ RequestBodyBS x -> return $ mBody x

241+ RequestBodyBuilder _ x -> return $ mBody $ toLazyByteString x

242+ RequestBodyStream _ x -> mBody <$> readBody x

243+ RequestBodyStreamChunked x -> mBody <$> readBody x

244+ RequestBodyIO x -> x >>= go

245+

246+ mBody :: ConvertibleStrings a String => a -> Maybe String

247+ mBody x = let y = cs x in if y == "" then Nothing else Just y

248+

249+ readBody writer = do

250+ m <- newIORef mempty

251+ _ <- writer (\bsAct -> do

252+ bs <- bsAct

253+ modifyIORef m (<> bs))

254+ readIORef m

255+

234

256

235-- * inspecting the xhr response

257-- * inspecting the xhr response

236

258