@@ -26,6 +26,7 @@ import Control.Monad.Trans.Control (MonadBaseControl (..))
2626import Control.Monad.Trans.Except
2727import Data.ByteString.Builder (toLazyByteString)
2828import qualified Data.ByteString.Char8 as BS
29+import qualified Data.ByteString.Lazy as BL
2930import Data.CaseInsensitive
3031import Data.Char
3132import Data.Foldable (toList)
@@ -34,11 +35,14 @@ import Data.IORef (modifyIORef, newIORef, readIORef)
3435import Data.Proxy (Proxy (..))
3536import qualified Data.Sequence as Seq
3637import Data.String.Conversions
38+import Data.Typeable (Typeable)
3739import Foreign.StablePtr
3840import GHC.Generics
41+import qualified GHCJS.Buffer as Buffer
3942import GHCJS.Foreign.Callback
4043import GHCJS.Prim
4144import GHCJS.Types
45+import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )
4246import JavaScript.Web.Location
4347import Network.HTTP.Media (renderHeader)
4448import Network.HTTP.Types
@@ -48,14 +52,34 @@ newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
4852
4953newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
5054
55+-- | The environment in which a request is run.
5156newtype ClientEnv
5257 = ClientEnv
5358 { baseUrl :: BaseUrl }
5459 deriving (Eq, Show)
5560
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!
5676client :: HasClient ClientM api => Proxy api -> Client ClientM api
5777client api = api `clientIn` (Proxy :: Proxy ClientM)
5878
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!
5983newtype ClientM a = ClientM
6084 { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
6185 deriving ( Functor, Applicative, Monad, MonadIO, Generic
@@ -76,8 +100,15 @@ instance MonadBaseControl IO ClientM where
76100instance Alt ClientM where
77101 a <!> b = a `catchError` const b
78102
103+data StreamingNotSupportedException = StreamingNotSupportedException
104+ deriving ( Typeable, Show )
105+
106+instance Exception StreamingNotSupportedException where
107+ displayException _ = "streamingRequest: streaming is not supported!"
108+
79109instance RunClient ClientM where
80110 runRequest = performRequest
111+ streamingRequest _ = liftIO $ throwIO StreamingNotSupportedException
81112 throwServantError = throwError
82113
83114instance ClientLike (ClientM a) (ClientM a) where
@@ -153,6 +184,7 @@ performXhr xhr burl request = do
153184
154185 openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
155186 setHeaders xhr request
187+ js_setResponseType xhr "arraybuffer"
156188 body <- toBody request
157189 sendXhr xhr body
158190 takeMVar waiter
@@ -187,6 +219,9 @@ openXhr xhr method url =
187219foreign import javascript unsafe "$1.open($2, $3, $4)"
188220 js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
189221
222+foreign import javascript unsafe "$1.responseType = $2;"
223+ js_setResponseType :: JSXMLHttpRequest -> JSString -> IO ()
224+
190225toUrl :: BaseUrl -> Request -> String
191226toUrl burl request =
192227 let pathS = cs $ toLazyByteString $ requestPath request
@@ -217,35 +252,38 @@ setHeaders xhr request = do
217252foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
218253 js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
219254
220−sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
255+sendXhr :: JSXMLHttpRequest -> Maybe ArrayBuffer -> IO ()
221256sendXhr xhr Nothing = js_sendXhr xhr
222257sendXhr xhr (Just body) =
223− js_sendXhrWithBody xhr (toJSString body)
258+ js_sendXhrWithBody xhr body
224259
225260foreign import javascript unsafe "$1.send()"
226261 js_sendXhr :: JSXMLHttpRequest -> IO ()
227262
228263foreign import javascript unsafe "$1.send($2)"
229− js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
264+ js_sendXhrWithBody :: JSXMLHttpRequest -> ArrayBuffer -> IO ()
230265
231−toBody :: Request -> IO (Maybe String)
266+toBody :: Request -> IO (Maybe ArrayBuffer)
232267toBody request = case requestBody request of
233268 Nothing -> return Nothing
234− Just (a, _) -> go a
269+ Just (a, _) -> Just <$> go a
235270
236271 where
237− go :: RequestBody -> IO (Maybe String)
272+ go :: RequestBody -> IO ArrayBuffer
238273 go x = case x of
239− RequestBodyLBS x -> return $ mBody x
274+ RequestBodyLBS x -> return $ mBody $ BL.toStrict x
240275 RequestBodyBS x -> return $ mBody x
241− RequestBodyBuilder _ x -> return $ mBody $ toLazyByteString x
276+ RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x
242277 RequestBodyStream _ x -> mBody <$> readBody x
243278 RequestBodyStreamChunked x -> mBody <$> readBody x
244279 RequestBodyIO x -> x >>= go
245280
246− mBody :: ConvertibleStrings a String => a -> Maybe String
247− mBody x = let y = cs x in if y == "" then Nothing else Just y
281+ mBody :: BS.ByteString -> ArrayBuffer
282+ mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
283+ where
284+ (buffer, offset, len) = Buffer.fromByteString bs
248285
286+ readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString
249287 readBody writer = do
250288 m <- newIORef mempty
251289 _ <- writer (\bsAct -> do
@@ -253,6 +291,8 @@ toBody request = case requestBody request of
253291 modifyIORef m (<> bs))
254292 readIORef m
255293
294+foreign import javascript unsafe "$3.slice($1, $1 + $2)"
295+ js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
256296
257297-- * inspecting the xhr response
258298
@@ -266,10 +306,10 @@ toResponse xhr = do
266306 _ -> liftIO $ do
267307 statusText <- cs <$> getStatusText xhr
268308 headers <- parseHeaders <$> getAllResponseHeaders xhr
269− responseText <- cs <$> getResponseText xhr
309+ response <- getResponse xhr
270310 pure Response
271311 { responseStatusCode = mkStatus status statusText
272− , responseBody = responseText
312+ , responseBody = response
273313 , responseHeaders = Seq.fromList headers
274314 , responseHttpVersion = http11 -- this is made up
275315 }
@@ -288,14 +328,19 @@ getAllResponseHeaders xhr =
288328foreign import javascript unsafe "$1.getAllResponseHeaders()"
289329 js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
290330
291−getResponseText :: JSXMLHttpRequest -> IO String
292−getResponseText xhr = fromJSString <$> js_responseText xhr
293−foreign import javascript unsafe "$1.responseText"
294− js_responseText :: JSXMLHttpRequest -> IO JSVal
331+getResponse :: JSXMLHttpRequest -> IO BL.ByteString
332+getResponse xhr =
333+ BL.fromStrict
334+ . Buffer.toByteString 0 Nothing
335+ . Buffer.createFromArrayBuffer
336+ <$> js_response xhr
337+
338+foreign import javascript unsafe "$1.response"
339+ js_response :: JSXMLHttpRequest -> IO ArrayBuffer
295340
296341parseHeaders :: String -> ResponseHeaders
297342parseHeaders s =
298− (first mk . first strip . second strip . parseHeader) <$>
343+ first mk . first strip . second strip . parseHeader <$>
299344 splitOn "\r\n" (cs s)
300345 where
301346 parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)