@@ -0,0 +1,311 @@
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