108df08 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

servant-client-ghcjs: Support binary requests

108df08Falco Peijnenburg9 years ago

servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+34−17

compare with master

unifiedsplit

@@ -26,6 +26,7 @@ import Control.Monad.Trans.Control (MonadBaseControl (..))

26import Control.Monad.Trans.Except

27import Data.ByteString.Builder (toLazyByteString)

28import qualified Data.ByteString.Char8 as BS

29+import qualified Data.ByteString.Lazy as BL

29import Data.CaseInsensitive

30import Data.CaseInsensitive

30import Data.Char

31import Data.Char

31import Data.Foldable (toList)

32import Data.Foldable (toList)

@@ -36,9 +37,11 @@ import qualified Data.Sequence as Seq

36import Data.String.Conversions

37import Data.String.Conversions

37import Foreign.StablePtr

38import Foreign.StablePtr

38import GHC.Generics

39import GHC.Generics

40+import qualified GHCJS.Buffer as Buffer

39import GHCJS.Foreign.Callback

41import GHCJS.Foreign.Callback

40import GHCJS.Prim

42import GHCJS.Prim

41import GHCJS.Types

43import GHCJS.Types

44+import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )

42import JavaScript.Web.Location

45import JavaScript.Web.Location

43import Network.HTTP.Media (renderHeader)

46import Network.HTTP.Media (renderHeader)

44import Network.HTTP.Types

47import Network.HTTP.Types

@@ -153,6 +156,7 @@ performXhr xhr burl request = do

153

156

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

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

155 setHeaders xhr request

158 setHeaders xhr request

159+ js_setResponseType xhr "arraybuffer"

156 body <- toBody request

160 body <- toBody request

157 sendXhr xhr body

161 sendXhr xhr body

158 takeMVar waiter

162 takeMVar waiter

@@ -187,6 +191,9 @@ openXhr xhr method url =

187foreign import javascript unsafe "$1.open($2, $3, $4)"

191foreign import javascript unsafe "$1.open($2, $3, $4)"

188 js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()

192 js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()

189

193

194+foreign import javascript unsafe "$1.responseType = $2;"

195+ js_setResponseType :: JSXMLHttpRequest -> JSString -> IO ()

196+

190toUrl :: BaseUrl -> Request -> String

197toUrl :: BaseUrl -> Request -> String

191toUrl burl request =

198toUrl burl request =

192 let pathS = cs $ toLazyByteString $ requestPath request

199 let pathS = cs $ toLazyByteString $ requestPath request

@@ -217,35 +224,38 @@ setHeaders xhr request = do

217foreign import javascript unsafe "$1.setRequestHeader($2, $3)"

224foreign import javascript unsafe "$1.setRequestHeader($2, $3)"

218 js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()

225 js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()

219

226

220−sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()

227+sendXhr :: JSXMLHttpRequest -> Maybe ArrayBuffer -> IO ()

221sendXhr xhr Nothing = js_sendXhr xhr

228sendXhr xhr Nothing = js_sendXhr xhr

222sendXhr xhr (Just body) =

229sendXhr xhr (Just body) =

223− js_sendXhrWithBody xhr (toJSString body)

230+ js_sendXhrWithBody xhr body

224

231

225foreign import javascript unsafe "$1.send()"

232foreign import javascript unsafe "$1.send()"

226 js_sendXhr :: JSXMLHttpRequest -> IO ()

233 js_sendXhr :: JSXMLHttpRequest -> IO ()

227

234

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

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

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

236+ js_sendXhrWithBody :: JSXMLHttpRequest -> ArrayBuffer -> IO ()

230

237

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

238+toBody :: Request -> IO (Maybe ArrayBuffer)

232toBody request = case requestBody request of

239toBody request = case requestBody request of

233 Nothing -> return Nothing

240 Nothing -> return Nothing

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

241+ Just (a, _) -> Just <$> go a

235

242

236 where

243 where

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

244+ go :: RequestBody -> IO ArrayBuffer

238 go x = case x of

245 go x = case x of

239− RequestBodyLBS x -> return $ mBody x

246+ RequestBodyLBS x -> return $ mBody $ BL.toStrict x

240 RequestBodyBS x -> return $ mBody x

247 RequestBodyBS x -> return $ mBody x

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

248+ RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x

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

249 RequestBodyStream _ x -> mBody <$> readBody x

243 RequestBodyStreamChunked x -> mBody <$> readBody x

250 RequestBodyStreamChunked x -> mBody <$> readBody x

244 RequestBodyIO x -> x >>= go

251 RequestBodyIO x -> x >>= go

245

252

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

253+ mBody :: BS.ByteString -> ArrayBuffer

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

254+ mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer

255+ where

256+ (buffer, offset, len) = Buffer.fromByteString bs

248

257

258+ readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString

249 readBody writer = do

259 readBody writer = do

250 m <- newIORef mempty

260 m <- newIORef mempty

251 _ <- writer (\bsAct -> do

261 _ <- writer (\bsAct -> do

@@ -253,6 +263,8 @@ toBody request = case requestBody request of

253 modifyIORef m (<> bs))

263 modifyIORef m (<> bs))

254 readIORef m

264 readIORef m

255

265

266+foreign import javascript unsafe "$3.slice($1, $1 + $2)"

267+ js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer

256

268

257-- * inspecting the xhr response

269-- * inspecting the xhr response

258

270

@@ -266,10 +278,10 @@ toResponse xhr = do

266 _ -> liftIO $ do

278 _ -> liftIO $ do

267 statusText <- cs <$> getStatusText xhr

279 statusText <- cs <$> getStatusText xhr

268 headers <- parseHeaders <$> getAllResponseHeaders xhr

280 headers <- parseHeaders <$> getAllResponseHeaders xhr

269− responseText <- cs <$> getResponseText xhr

281+ response <- getResponse xhr

270 pure Response

282 pure Response

271 { responseStatusCode = mkStatus status statusText

283 { responseStatusCode = mkStatus status statusText

272− , responseBody = responseText

284+ , responseBody = response

273 , responseHeaders = Seq.fromList headers

285 , responseHeaders = Seq.fromList headers

274 , responseHttpVersion = http11 -- this is made up

286 , responseHttpVersion = http11 -- this is made up

275 }

287 }

@@ -288,14 +300,19 @@ getAllResponseHeaders xhr =

288foreign import javascript unsafe "$1.getAllResponseHeaders()"

300foreign import javascript unsafe "$1.getAllResponseHeaders()"

289 js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal

301 js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal

290

302

291−getResponseText :: JSXMLHttpRequest -> IO String

303+getResponse :: JSXMLHttpRequest -> IO BL.ByteString

292−getResponseText xhr = fromJSString <$> js_responseText xhr

304+getResponse xhr =

305+ BL.fromStrict

306+ . Buffer.toByteString 0 Nothing

307+ . Buffer.createFromArrayBuffer

308+ <$> js_response xhr

309+

293−foreign import javascript unsafe "$1.responseText"

310+foreign import javascript unsafe "$1.response"

294− js_responseText :: JSXMLHttpRequest -> IO JSVal

311+ js_response :: JSXMLHttpRequest -> IO ArrayBuffer

295

312

296parseHeaders :: String -> ResponseHeaders

313parseHeaders :: String -> ResponseHeaders

297parseHeaders s =

314parseHeaders s =

298− (first mk . first strip . second strip . parseHeader) <$>

315+ first mk . first strip . second strip . parseHeader <$>

299 splitOn "\r\n" (cs s)

316 splitOn "\r\n" (cs s)

300 where

317 where

301 parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)

318 parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)