@@ -1,311 +0,0 @@
1−{-# LANGUAGE CPP #-}
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 #-}
14−
15−module Servant.Client.Internal.JSaddleXhrClient where
16−
17−import Prelude ()
18−import Prelude.Compat
19−
20−import Control.Concurrent
21− (MVar, newEmptyMVar, takeMVar, tryPutMVar)
22−import Control.Exception
23− (Exception, toException)
24−import Control.Monad
25− (forM_, unless, void)
26−import Control.Monad.Catch
27− (MonadCatch, MonadThrow, catch)
28−import Control.Monad.Error.Class
29− (MonadError (..))
30−import Control.Monad.IO.Class
31− (MonadIO (..))
32−import Control.Monad.Reader
33− (MonadReader, ReaderT, asks, runReaderT)
34−import Control.Monad.Trans.Except
35− (ExceptT, runExceptT)
36−import Data.Bifunctor
37− (bimap, first, second)
38−import Data.ByteString.Builder
39− (toLazyByteString)
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
44− (mk, original)
45−import Data.Char
46− (isSpace)
47−import Data.Foldable
48− (toList)
49−import Data.Functor.Alt
50− (Alt (..))
51−import Data.Proxy
52− (Proxy (..))
53−import qualified Data.Sequence as Seq
54−import Data.String.Conversions
55− (cs)
56−import qualified Data.Text.Encoding as T
57−import qualified Data.Text.Encoding.Error as T
58−import GHC.Generics
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
71− (renderHeader)
72−import Network.HTTP.Types
73− (ResponseHeaders, http11, mkStatus, renderQuery, statusCode)
74−import System.IO
75− (hPutStrLn, stderr)
76−
77−import Servant.Client.Core
78−
79−-- Note: assuming encoding UTF-8
80−
81−data ClientEnv
82− = ClientEnv
83− { baseUrl :: BaseUrl
84− -- | Modify the XMLHttpRequest at will, right before sending.
85− , fixUpXhr :: JS.XMLHttpRequest -> DOM ()
86− }
87−
88−data JSaddleConnectionError = JSaddleConnectionError
89− deriving (Eq, Show)
90−
91−instance Exception JSaddleConnectionError
92−
93−-- | Default 'ClientEnv'
94−mkClientEnv :: BaseUrl -> ClientEnv
95−mkClientEnv burl = ClientEnv burl (const (pure ()))
96−
97−instance Show ClientEnv where
98− showsPrec prec (ClientEnv burl _) =
99− showParen (prec >= 11)
100− ( showString "ClientEnv {"
101− . showString "baseUrl = "
102− . showsPrec 0 burl
103− . showString ", fixUpXhr = <function>"
104− . showString "}"
105− )
106−
107−client :: HasClient ClientM api => Proxy api -> Client ClientM api
108−client api = api `clientIn` (Proxy :: Proxy ClientM)
109−
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
116−
117−-- | Try clients in order, last error is preserved.
118−instance Alt ClientM where
119− a <!> b = a `catchError` const b
120−
121−instance RunClient ClientM where
122− throwClientError = throwError
123− runRequest r = do
124− d <- ClientM askDOM
125− performRequest d r
126−
127−runClientM :: ClientM a -> ClientEnv -> DOM (Either ClientError a)
128−runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm
129−
130−runClientM' :: ClientM a -> DOM (Either ClientError a)
131−runClientM' m = do
132− burl <- getDefaultBaseUrl
133− runClientM m (mkClientEnv burl)
134−
135−getDefaultBaseUrl :: DOM BaseUrl
136−getDefaultBaseUrl = do
137− win <- GHCJS.DOM.currentWindow >>= \mw -> case mw of
138− Just x -> pure x
139− Nothing -> fail "Can not determine default base url without window."
140− curLoc <- Window.getLocation win
141−
142− protocolStr <- Location.getProtocol curLoc
143− portStr <- Location.getPort curLoc
144− hostname <- Location.getHostname curLoc
145−
146− let protocol
147− | (protocolStr :: JS.JSString) == "https:"
148− = Https
149− | otherwise = Http
150−
151− port :: Int
152− port | null portStr = case protocol of
153− Http -> 80
154− Https -> 443
155− | otherwise = read portStr
156−
157− pure (BaseUrl protocol hostname port "")
158−
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
166−
167− let status = statusCode (responseStatusCode resp)
168− unless (status >= 200 && status < 300) $
169− throwError $ mkFailureResponse burl req resp
170−
171− pure resp
172−
173−
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
178−
179− let username, password :: Maybe JS.JSString
180− username = Nothing; password = Nothing
181−
182− JS.open xhr (decodeUtf8Lenient $ requestMethod request) (toUrl burl request) True username password
183− setHeaders xhr request
184− fixUp xhr
185−
186− waiter <- liftIO $ newEmptyMVar
187−
188− cleanup <- JSDOM.on xhr JS.readyStateChange $ do
189− state <- JS.getReadyState xhr
190− case state of
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 ()
197− _ -> return ()
198−
199− sendXhr xhr (toBody request) `catch` handleXHRError waiter -- We handle any errors in `toResponse`.
200−
201− liftIO $ takeMVar waiter
202−
203− cleanup
204−
205− where
206−
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 ()
211−
212−
213−toUrl :: BaseUrl -> Request -> JS.JSString
214−toUrl burl request =
215− let pathS = JS.toJSString $ decodeUtf8Lenient $ L.toStrict $ toLazyByteString $
216− requestPath request
217− queryS =
218− JS.toJSString $ decodeUtf8Lenient $
219− renderQuery True $
220− toList $
221− requestQueryString request
222− in JS.toJSString (showBaseUrl burl) <> pathS <> queryS :: JS.JSString
223−
224−setHeaders :: JS.XMLHttpRequest -> Request -> DOM ()
225−setHeaders xhr request = do
226− forM_ (toList $ requestAccept request) $ \mediaType -> -- FIXME review
227− JS.setRequestHeader
228− xhr
229− ("Accept" :: JS.JSString)
230− (decodeUtf8Lenient $ renderHeader mediaType)
231−
232− forM_ (requestBody request) $ \(_, mediaType) ->
233− JS.setRequestHeader
234− xhr
235− ("Content-Type" :: JS.JSString)
236− (decodeUtf8Lenient $ renderHeader mediaType)
237−
238− forM_ (toList $ requestHeaders request) $ \(key, value) ->
239− JS.setRequestHeader xhr (decodeUtf8Lenient $ original key) (decodeUtf8Lenient value)
240−
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
245−
246−mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
247−mkFailureResponse burl request =
248− FailureResponse (bimap (const ()) f request)
249− where
250− f b = (burl, BSL.toStrict $ toLazyByteString b)
251−
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
258− b' <- Buffer.thaw b
259− b'' <- JSaddle.ghcjsPure $ Buffer.getArrayBuffer b'
260− JS.sendArrayBuffer xhr =<< castMutableArrayBufferToArrayBufferView b''
261−
262−toBody :: Request -> Maybe L.ByteString
263−toBody request = case requestBody request of
264− Nothing -> Nothing
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"
270−
271−-- * inspecting the xhr response
272−
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
280− case status of
281− 0 -> throwError $ ConnectionError $ toException JSaddleConnectionError
282− _ -> inDom $ do
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?
286− pure Response
287− { responseStatusCode = mkStatus (fromIntegral status) statusText
288− , responseBody = responseText
289− , responseHeaders = Seq.fromList headers
290− , responseHttpVersion = http11 -- this is made up
291− }
292−
293−parseHeaders :: String -> ResponseHeaders
294−parseHeaders s =
295− (first mk . first strip . second strip . parseHeader) <$>
296− splitOn "\r\n" (cs s)
297− where
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)
301−
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)
306−
307− strip :: BS.ByteString -> BS.ByteString
308− strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse
309−
310−decodeUtf8Lenient :: BS.ByteString -> JS.JSString
311−decodeUtf8Lenient = JS.toJSString . T.decodeUtf8With T.lenientDecode