@@ -1,311 +0,0 @@
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE StandaloneDeriving #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE UndecidableInstances #-}
12−{-# LANGUAGE ViewPatterns #-}
13−{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
15−module Servant.Client.Internal.JSaddleXhrClient where
20−import Control.Concurrent
21− (MVar, newEmptyMVar, takeMVar, tryPutMVar)
22−import Control.Exception
23− (Exception, toException)
25− (forM_, unless, void)
26−import Control.Monad.Catch
27− (MonadCatch, MonadThrow, catch)
28−import Control.Monad.Error.Class
30−import Control.Monad.IO.Class
32−import Control.Monad.Reader
33− (MonadReader, ReaderT, asks, runReaderT)
34−import Control.Monad.Trans.Except
35− (ExceptT, runExceptT)
37− (bimap, first, second)
38−import Data.ByteString.Builder
40−import qualified Data.ByteString.Char8 as BS
41−import qualified Data.ByteString.Lazy as BSL
42−import qualified Data.ByteString.Lazy as L
43−import Data.CaseInsensitive
49−import Data.Functor.Alt
53−import qualified Data.Sequence as Seq
54−import Data.String.Conversions
56−import qualified Data.Text.Encoding as T
57−import qualified Data.Text.Encoding.Error as T
59−import qualified GHCJS.Buffer as Buffer
60−import qualified GHCJS.DOM
61−import qualified GHCJS.DOM.EventM as JSDOM
62−import qualified GHCJS.DOM.Location as Location
63−import GHCJS.DOM.Types
64− (DOM, DOMContext, askDOM, runDOM)
65−import qualified GHCJS.DOM.Types as JS
66−import qualified GHCJS.DOM.Window as Window
67−import qualified GHCJS.DOM.XMLHttpRequest as JS
68−import qualified JavaScript.TypedArray.ArrayBuffer as ArrayBuffer
69−import qualified Language.Javascript.JSaddle.Types as JSaddle
70−import Network.HTTP.Media
72−import Network.HTTP.Types
73− (ResponseHeaders, http11, mkStatus, renderQuery, statusCode)
77−import Servant.Client.Core
79−-- Note: assuming encoding UTF-8
84− -- | Modify the XMLHttpRequest at will, right before sending.
85− , fixUpXhr :: JS.XMLHttpRequest -> DOM ()
88−data JSaddleConnectionError = JSaddleConnectionError
91−instance Exception JSaddleConnectionError
93−-- | Default 'ClientEnv'
94−mkClientEnv :: BaseUrl -> ClientEnv
95−mkClientEnv burl = ClientEnv burl (const (pure ()))
97−instance Show ClientEnv where
98− showsPrec prec (ClientEnv burl _) =
99− showParen (prec >= 11)
100− ( showString "ClientEnv {"
101− . showString "baseUrl = "
103− . showString ", fixUpXhr = <function>"
107−client :: HasClient ClientM api => Proxy api -> Client ClientM api
108−client api = api `clientIn` (Proxy :: Proxy ClientM)
110−newtype ClientM a = ClientM
111− { fromClientM :: ReaderT ClientEnv (ExceptT ClientError DOM) a }
112− deriving ( Functor, Applicative, Monad, MonadIO, Generic
113− , MonadReader ClientEnv, MonadError ClientError)
114−deriving instance MonadThrow DOM => MonadThrow ClientM
115−deriving instance MonadCatch DOM => MonadCatch ClientM
117−-- | Try clients in order, last error is preserved.
118−instance Alt ClientM where
119− a <!> b = a `catchError` const b
121−instance RunClient ClientM where
122− throwClientError = throwError
127−runClientM :: ClientM a -> ClientEnv -> DOM (Either ClientError a)
128−runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm
130−runClientM' :: ClientM a -> DOM (Either ClientError a)
132− burl <- getDefaultBaseUrl
133− runClientM m (mkClientEnv burl)
135−getDefaultBaseUrl :: DOM BaseUrl
136−getDefaultBaseUrl = do
137− win <- GHCJS.DOM.currentWindow >>= \mw -> case mw of
139− Nothing -> fail "Can not determine default base url without window."
140− curLoc <- Window.getLocation win
142− protocolStr <- Location.getProtocol curLoc
143− portStr <- Location.getPort curLoc
144− hostname <- Location.getHostname curLoc
147− | (protocolStr :: JS.JSString) == "https:"
152− port | null portStr = case protocol of
155− | otherwise = read portStr
157− pure (BaseUrl protocol hostname port "")
159−performRequest :: DOMContext -> Request -> ClientM Response
160−performRequest domc req = do
161− xhr <- JS.newXMLHttpRequest `runDOM` domc
162− burl <- asks baseUrl
163− fixUp <- asks fixUpXhr
164− performXhr xhr burl req fixUp `runDOM` domc
165− resp <- toResponse domc xhr
167− let status = statusCode (responseStatusCode resp)
168− unless (status >= 200 && status < 300) $
169− throwError $ mkFailureResponse burl req resp
174−-- * performing requests
175−-- Performs the xhr and blocks until the response was received
176−performXhr :: JS.XMLHttpRequest -> BaseUrl -> Request -> (JS.XMLHttpRequest -> DOM ()) -> DOM ()
177−performXhr xhr burl request fixUp = do
179− let username, password :: Maybe JS.JSString
180− username = Nothing; password = Nothing
182− JS.open xhr (decodeUtf8Lenient $ requestMethod request) (toUrl burl request) True username password
183− setHeaders xhr request
186− waiter <- liftIO $ newEmptyMVar
188− cleanup <- JSDOM.on xhr JS.readyStateChange $ do
189− state <- JS.getReadyState xhr
191− -- onReadyStateChange's callback can fire state 4
192− -- (which means "request finished and response is ready")
193− -- multiple times. By using tryPutMVar, only the first time
194− -- state 4 is fired will cause an MVar to be put. Subsequent
195− -- fires are ignored.
196− 4 -> void $ liftIO $ tryPutMVar waiter ()
199− sendXhr xhr (toBody request) `catch` handleXHRError waiter -- We handle any errors in `toResponse`.
201− liftIO $ takeMVar waiter
207− handleXHRError :: MVar () -> JS.XHRError -> DOM ()
208− handleXHRError waiter e = do
209− liftIO $ hPutStrLn stderr $ "servant-client-jsaddle: exception in `sendXhr` (should get handled in response handling): " <> show e
210− void $ liftIO $ tryPutMVar waiter ()
213−toUrl :: BaseUrl -> Request -> JS.JSString
215− let pathS = JS.toJSString $ decodeUtf8Lenient $ L.toStrict $ toLazyByteString $
218− JS.toJSString $ decodeUtf8Lenient $
221− requestQueryString request
222− in JS.toJSString (showBaseUrl burl) <> pathS <> queryS :: JS.JSString
224−setHeaders :: JS.XMLHttpRequest -> Request -> DOM ()
225−setHeaders xhr request = do
226− forM_ (toList $ requestAccept request) $ \mediaType -> -- FIXME review
229− ("Accept" :: JS.JSString)
230− (decodeUtf8Lenient $ renderHeader mediaType)
232− forM_ (requestBody request) $ \(_, mediaType) ->
235− ("Content-Type" :: JS.JSString)
236− (decodeUtf8Lenient $ renderHeader mediaType)
238− forM_ (toList $ requestHeaders request) $ \(key, value) ->
239− JS.setRequestHeader xhr (decodeUtf8Lenient $ original key) (decodeUtf8Lenient value)
241−-- ArrayBufferView is a type that only exists in the spec and covers many concrete types.
242−castMutableArrayBufferToArrayBufferView :: ArrayBuffer.MutableArrayBuffer -> DOM JS.ArrayBufferView
243−castMutableArrayBufferToArrayBufferView x = JS.liftJSM $ do
244− JS.fromJSValUnchecked $ JS.pToJSVal x
246−mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
247−mkFailureResponse burl request =
248− FailureResponse (bimap (const ()) f request)
250− f b = (burl, BSL.toStrict $ toLazyByteString b)
252−sendXhr :: JS.XMLHttpRequest -> Maybe L.ByteString -> DOM ()
253−sendXhr xhr Nothing = JS.send xhr
254−sendXhr xhr (Just body) = do
255− -- Reason for copy: hopefully offset will be 0 and length b == len
256− -- FIXME: use a typed array constructor that accepts offset and length and skip the copy
257− (b, _offset, _len) <- JSaddle.ghcjsPure $ Buffer.fromByteString $ BS.copy $ L.toStrict body
259− b'' <- JSaddle.ghcjsPure $ Buffer.getArrayBuffer b'
260− JS.sendArrayBuffer xhr =<< castMutableArrayBufferToArrayBufferView b''
262−toBody :: Request -> Maybe L.ByteString
263−toBody request = case requestBody request of
265− Just (RequestBodyLBS "", _) -> Nothing
266− Just (RequestBodyLBS x, _) -> Just x
267− Just (RequestBodyBS "", _) -> Nothing
268− Just (RequestBodyBS x, _) -> Just $ L.fromStrict x
269− Just (RequestBodySource _, _) -> error "RequestBodySource isn't supported"
271−-- * inspecting the xhr response
273−-- This function is only supposed to handle 'ConnectionError's. Other
274−-- 'ClientError's are created in Servant.Client.Req.
275−toResponse :: DOMContext -> JS.XMLHttpRequest -> ClientM Response
276−toResponse domc xhr = do
277− let inDom :: DOM a -> ClientM a
278− inDom = flip runDOM domc
279− status <- inDom $ JS.getStatus xhr
281− 0 -> throwError $ ConnectionError $ toException JSaddleConnectionError
283− statusText <- BS.pack <$> JS.getStatusText xhr
284− headers <- parseHeaders <$> JS.getAllResponseHeaders xhr
285− responseText <- maybe "" (L.fromStrict . BS.pack) <$> JS.getResponseText xhr -- FIXME: Text/Binary? Performance? Test?
287− { responseStatusCode = mkStatus (fromIntegral status) statusText
288− , responseBody = responseText
289− , responseHeaders = Seq.fromList headers
290− , responseHttpVersion = http11 -- this is made up
293−parseHeaders :: String -> ResponseHeaders
295− (first mk . first strip . second strip . parseHeader) <$>
296− splitOn "\r\n" (cs s)
298− parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
299− parseHeader h = case BS.breakSubstring ":" (cs h) of
300− (key, BS.drop 1 -> value) -> (key, value)
302− splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
303− splitOn separator input = case BS.breakSubstring separator input of
304− (prefix, "") -> [prefix]
305− (prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
307− strip :: BS.ByteString -> BS.ByteString
308− strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse
310−decodeUtf8Lenient :: BS.ByteString -> JS.JSString
311−decodeUtf8Lenient = JS.toJSString . T.decodeUtf8With T.lenientDecode