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

servant-client-ghcjs: Support binary requests

Author: phadej

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

@@ -26,6 +26,7 @@ import           Control.Monad.Trans.Control (MonadBaseControl (..))
 import           Control.Monad.Trans.Except
 import           Data.ByteString.Builder     (toLazyByteString)
 import qualified Data.ByteString.Char8       as BS
+import qualified Data.ByteString.Lazy        as BL
 import           Data.CaseInsensitive
 import           Data.Char
 import           Data.Foldable               (toList)
@@ -34,11 +35,14 @@ import           Data.IORef                  (modifyIORef, newIORef, readIORef)
 import           Data.Proxy                  (Proxy (..))
 import qualified Data.Sequence               as Seq
 import           Data.String.Conversions
+import           Data.Typeable           (Typeable)
 import           Foreign.StablePtr
 import           GHC.Generics
+import qualified GHCJS.Buffer as Buffer
 import           GHCJS.Foreign.Callback
 import           GHCJS.Prim
 import           GHCJS.Types
+import           JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )
 import           JavaScript.Web.Location
 import           Network.HTTP.Media          (renderHeader)
 import           Network.HTTP.Types
@@ -48,14 +52,34 @@ newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
 
 newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
 
+-- | The environment in which a request is run.
 newtype ClientEnv
    = ClientEnv
    { baseUrl :: BaseUrl }
    deriving (Eq, Show)
 
+-- | Generates a set of client functions for an API.
+--
+-- Example:
+--
+-- > type API = Capture "no" Int :> Get '[JSON] Int
+-- >        :<|> Get '[JSON] [Bool]
+-- >
+-- > api :: Proxy API
+-- > api = Proxy
+-- >
+-- > getInt :: Int -> ClientM Int
+-- > getBools :: ClientM [Bool]
+-- > getInt :<|> getBools = client api
+--
+-- NOTE: Does not support constant space streaming of the request body!
 client :: HasClient ClientM api => Proxy api -> Client ClientM api
 client api = api `clientIn` (Proxy :: Proxy ClientM)
 
+-- | @ClientM@ is the monad in which client functions run. Contains the
+-- 'BaseUrl' used for requests in the reader environment.
+--
+-- NOTE: Does not support constant space streaming of the request body!
 newtype ClientM a = ClientM
   { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
   deriving ( Functor, Applicative, Monad, MonadIO, Generic
@@ -76,8 +100,15 @@ instance MonadBaseControl IO ClientM where
 instance Alt ClientM where
   a <!> b = a `catchError` const b
 
+data StreamingNotSupportedException = StreamingNotSupportedException
+  deriving ( Typeable, Show )
+
+instance Exception StreamingNotSupportedException where
+  displayException _ = "streamingRequest: streaming is not supported!"
+
 instance RunClient ClientM where
   runRequest = performRequest
+  streamingRequest _ = liftIO $ throwIO StreamingNotSupportedException
   throwServantError = throwError
 
 instance ClientLike (ClientM a) (ClientM a) where
@@ -153,6 +184,7 @@ performXhr xhr burl request = do
 
         openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
         setHeaders xhr request
+        js_setResponseType xhr "arraybuffer"
         body <- toBody request
         sendXhr xhr body
         takeMVar waiter
@@ -187,6 +219,9 @@ openXhr xhr method url =
 foreign import javascript unsafe "$1.open($2, $3, $4)"
   js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
 
+foreign import javascript unsafe "$1.responseType = $2;"
+  js_setResponseType :: JSXMLHttpRequest -> JSString -> IO ()
+
 toUrl :: BaseUrl -> Request -> String
 toUrl burl request =
   let pathS = cs $ toLazyByteString $ requestPath request
@@ -217,42 +252,47 @@ setHeaders xhr request = do
 foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
   js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
 
-sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
+sendXhr :: JSXMLHttpRequest -> Maybe ArrayBuffer -> IO ()
 sendXhr xhr Nothing = js_sendXhr xhr
 sendXhr xhr (Just body) =
-  js_sendXhrWithBody xhr (toJSString body)
+  js_sendXhrWithBody xhr body
 
 foreign import javascript unsafe "$1.send()"
   js_sendXhr :: JSXMLHttpRequest -> IO ()
 
 foreign import javascript unsafe "$1.send($2)"
-  js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
+  js_sendXhrWithBody :: JSXMLHttpRequest -> ArrayBuffer -> IO ()
 
-toBody :: Request -> IO (Maybe String)
+toBody :: Request -> IO (Maybe ArrayBuffer)
 toBody request = case requestBody request of
   Nothing -> return Nothing
-  Just (a, _) -> go a
+  Just (a, _) -> Just <$> go a
 
   where
-    go :: RequestBody -> IO (Maybe String)
+    go :: RequestBody -> IO ArrayBuffer
     go x = case x of
-      RequestBodyLBS x -> return $ mBody x
+      RequestBodyLBS x -> return $ mBody $ BL.toStrict x
       RequestBodyBS x -> return $ mBody x
-      RequestBodyBuilder _ x -> return $ mBody $ toLazyByteString x
+      RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ 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
+    mBody :: BS.ByteString -> ArrayBuffer
+    mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
+      where
+        (buffer, offset, len) = Buffer.fromByteString bs
 
+    readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString
     readBody writer = do
       m <- newIORef mempty
       _ <- writer (\bsAct -> do
         bs <- bsAct
         modifyIORef m (<> bs))
       readIORef m
 
+foreign import javascript unsafe "$3.slice($1, $1 + $2)"
+  js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
 
 -- * inspecting the xhr response
 
@@ -266,10 +306,10 @@ toResponse xhr = do
     _ -> liftIO $ do
       statusText <- cs <$> getStatusText xhr
       headers <- parseHeaders <$> getAllResponseHeaders xhr
-      responseText <- cs <$> getResponseText xhr
+      response <- getResponse xhr
       pure Response
         { responseStatusCode = mkStatus status statusText
-        , responseBody = responseText
+        , responseBody = response
         , responseHeaders = Seq.fromList headers
         , responseHttpVersion = http11 -- this is made up
         }
@@ -288,14 +328,19 @@ getAllResponseHeaders xhr =
 foreign import javascript unsafe "$1.getAllResponseHeaders()"
   js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
 
-getResponseText :: JSXMLHttpRequest -> IO String
-getResponseText xhr = fromJSString <$> js_responseText xhr
-foreign import javascript unsafe "$1.responseText"
-  js_responseText :: JSXMLHttpRequest -> IO JSVal
+getResponse :: JSXMLHttpRequest -> IO BL.ByteString
+getResponse xhr =
+    BL.fromStrict
+  . Buffer.toByteString 0 Nothing
+  . Buffer.createFromArrayBuffer
+  <$> js_response xhr
+
+foreign import javascript unsafe "$1.response"
+  js_response :: JSXMLHttpRequest -> IO ArrayBuffer
 
 parseHeaders :: String -> ResponseHeaders
 parseHeaders s =
-  (first mk . first strip . second strip . parseHeader) <$>
+  first mk . first strip . second strip . parseHeader <$>
   splitOn "\r\n" (cs s)
   where
     parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)