187c3f4 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Merge pull request #938 from LumiGuide/feat-binary-requests

187c3f4Oleg Grenrus8 years ago

servant-client-ghcjs/src/Servant/Client/Internal/XhrClient.hs+62−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)

@@ -34,11 +35,14 @@ import Data.IORef (modifyIORef, newIORef, readIORef)

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

35import Data.Proxy (Proxy (..))

35import qualified Data.Sequence as Seq

36import qualified Data.Sequence as Seq

36import Data.String.Conversions

37import Data.String.Conversions

38+import Data.Typeable (Typeable)

37import Foreign.StablePtr

39import Foreign.StablePtr

38import GHC.Generics

40import GHC.Generics

41+import qualified GHCJS.Buffer as Buffer

39import GHCJS.Foreign.Callback

42import GHCJS.Foreign.Callback

40import GHCJS.Prim

43import GHCJS.Prim

41import GHCJS.Types

44import GHCJS.Types

45+import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )

42import JavaScript.Web.Location

46import JavaScript.Web.Location

43import Network.HTTP.Media (renderHeader)

47import Network.HTTP.Media (renderHeader)

44import Network.HTTP.Types

48import Network.HTTP.Types

@@ -48,14 +52,34 @@ newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal

49newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal

53newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal

55+-- | The environment in which a request is run.

51newtype ClientEnv

56newtype ClientEnv

52 = ClientEnv

57 = ClientEnv

53 { baseUrl :: BaseUrl }

58 { baseUrl :: BaseUrl }

54 deriving (Eq, Show)

59 deriving (Eq, Show)

61+-- | Generates a set of client functions for an API.

62+--

63+-- Example:

64+--

65+-- > type API = Capture "no" Int :> Get '[JSON] Int

66+-- > :<|> Get '[JSON] [Bool]

67+-- >

68+-- > api :: Proxy API

69+-- > api = Proxy

70+-- >

71+-- > getInt :: Int -> ClientM Int

72+-- > getBools :: ClientM [Bool]

73+-- > getInt :<|> getBools = client api

74+--

75+-- NOTE: Does not support constant space streaming of the request body!

56client :: HasClient ClientM api => Proxy api -> Client ClientM api

76client :: HasClient ClientM api => Proxy api -> Client ClientM api

57client api = api `clientIn` (Proxy :: Proxy ClientM)

77client api = api `clientIn` (Proxy :: Proxy ClientM)

79+-- | @ClientM@ is the monad in which client functions run. Contains the

80+-- 'BaseUrl' used for requests in the reader environment.

81+--

82+-- NOTE: Does not support constant space streaming of the request body!

59newtype ClientM a = ClientM

83newtype ClientM a = ClientM

60 { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }

84 { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }

61 deriving ( Functor, Applicative, Monad, MonadIO, Generic

85 deriving ( Functor, Applicative, Monad, MonadIO, Generic

@@ -76,8 +100,15 @@ instance MonadBaseControl IO ClientM where

76instance Alt ClientM where

100instance Alt ClientM where

77 a <!> b = a `catchError` const b

101 a <!> b = a `catchError` const b

102

103+data StreamingNotSupportedException = StreamingNotSupportedException

104+ deriving ( Typeable, Show )

105+

106+instance Exception StreamingNotSupportedException where

107+ displayException _ = "streamingRequest: streaming is not supported!"

108+

79instance RunClient ClientM where

109instance RunClient ClientM where

80 runRequest = performRequest

110 runRequest = performRequest

111+ streamingRequest _ = liftIO $ throwIO StreamingNotSupportedException

81 throwServantError = throwError

112 throwServantError = throwError

113

83instance ClientLike (ClientM a) (ClientM a) where

114instance ClientLike (ClientM a) (ClientM a) where

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

153

184

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

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

155 setHeaders xhr request

186 setHeaders xhr request

187+ js_setResponseType xhr "arraybuffer"

156 body <- toBody request

188 body <- toBody request

157 sendXhr xhr body

189 sendXhr xhr body

158 takeMVar waiter

190 takeMVar waiter

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

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

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

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

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

189

221

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

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

224+

190toUrl :: BaseUrl -> Request -> String

225toUrl :: BaseUrl -> Request -> String

191toUrl burl request =

226toUrl burl request =

192 let pathS = cs $ toLazyByteString $ requestPath request

227 let pathS = cs $ toLazyByteString $ requestPath request

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

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

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

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

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

219

254

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

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

221sendXhr xhr Nothing = js_sendXhr xhr

256sendXhr xhr Nothing = js_sendXhr xhr

222sendXhr xhr (Just body) =

257sendXhr xhr (Just body) =

223− js_sendXhrWithBody xhr (toJSString body)

258+ js_sendXhrWithBody xhr body

224

259

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

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

226 js_sendXhr :: JSXMLHttpRequest -> IO ()

261 js_sendXhr :: JSXMLHttpRequest -> IO ()

227

262

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

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

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

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

230

265

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

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

232toBody request = case requestBody request of

267toBody request = case requestBody request of

233 Nothing -> return Nothing

268 Nothing -> return Nothing

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

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

235

270

236 where

271 where

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

272+ go :: RequestBody -> IO ArrayBuffer

238 go x = case x of

273 go x = case x of

239− RequestBodyLBS x -> return $ mBody x

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

240 RequestBodyBS x -> return $ mBody x

275 RequestBodyBS x -> return $ mBody x

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

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

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

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

243 RequestBodyStreamChunked x -> mBody <$> readBody x

278 RequestBodyStreamChunked x -> mBody <$> readBody x

244 RequestBodyIO x -> x >>= go

279 RequestBodyIO x -> x >>= go

245

280

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

281+ mBody :: BS.ByteString -> ArrayBuffer

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

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

283+ where

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

248

285

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

249 readBody writer = do

287 readBody writer = do

250 m <- newIORef mempty

288 m <- newIORef mempty

251 _ <- writer (\bsAct -> do

289 _ <- writer (\bsAct -> do

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

253 modifyIORef m (<> bs))

291 modifyIORef m (<> bs))

254 readIORef m

292 readIORef m

255

293

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

295+ js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer

256

296

257-- * inspecting the xhr response

297-- * inspecting the xhr response

258

298

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

266 _ -> liftIO $ do

306 _ -> liftIO $ do

267 statusText <- cs <$> getStatusText xhr

307 statusText <- cs <$> getStatusText xhr

268 headers <- parseHeaders <$> getAllResponseHeaders xhr

308 headers <- parseHeaders <$> getAllResponseHeaders xhr

269− responseText <- cs <$> getResponseText xhr

309+ response <- getResponse xhr

270 pure Response

310 pure Response

271 { responseStatusCode = mkStatus status statusText

311 { responseStatusCode = mkStatus status statusText

272− , responseBody = responseText

312+ , responseBody = response

273 , responseHeaders = Seq.fromList headers

313 , responseHeaders = Seq.fromList headers

274 , responseHttpVersion = http11 -- this is made up

314 , responseHttpVersion = http11 -- this is made up

275 }

315 }

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

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

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

289 js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal

329 js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal

290

330

291−getResponseText :: JSXMLHttpRequest -> IO String

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

292−getResponseText xhr = fromJSString <$> js_responseText xhr

332+getResponse xhr =

333+ BL.fromStrict

334+ . Buffer.toByteString 0 Nothing

335+ . Buffer.createFromArrayBuffer

336+ <$> js_response xhr

337+

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

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

294− js_responseText :: JSXMLHttpRequest -> IO JSVal

339+ js_response :: JSXMLHttpRequest -> IO ArrayBuffer

295

340

296parseHeaders :: String -> ResponseHeaders

341parseHeaders :: String -> ResponseHeaders

297parseHeaders s =

342parseHeaders s =

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

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

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

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

300 where

345 where

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

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