@@ -0,0 +1,77 @@
1+{-# LANGUAGE CPP #-}
2+module Reflex.Dom.Xhr where
3+
4+#ifdef __GHCJS__
5+import Control.Lens
6+import Control.Monad
7+import Control.Monad.IO.Class
8+import Data.Default
9+import Data.Map (Map)
10+import qualified Data.Map as Map
11+import Data.Maybe
12+import Data.Text (Text)
13+import qualified Data.Text as T
14+import GHCJS.Foreign
15+import GHCJS.Types
16+import GHCJS.DOM.XMLHttpRequest
17+import Reflex
18+import Reflex.Dom.Class
19+
20+data XhrRequest
21+ = XhrRequest { _xhrRequest_method :: String
22+ , _xhrRequest_url :: String
23+ , _xhrRequest_config :: XhrRequestConfig
24+ }
25+
26+data XhrRequestConfig
27+ = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String
28+ , _xhrRequestConfig_user :: Maybe String
29+ , _xhrRequestConfig_password :: Maybe String
30+ , _xhrRequestConfig_responseType :: Maybe String
31+ , _xhrRequestConfig_sendData :: Maybe String
32+ }
33+
34+data XhrResponse
35+ = XhrResponse { _xhrResponse_body :: Maybe JSString
36+ }
37+
38+instance Default XhrRequestConfig where
39+ def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty
40+ , _xhrRequestConfig_user = Nothing
41+ , _xhrRequestConfig_password = Nothing
42+ , _xhrRequestConfig_responseType = Nothing
43+ , _xhrRequestConfig_sendData = Nothing
44+ }
45+
46+xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
47+xhrRequest = XhrRequest
48+
49+newXMLHttpRequest :: XhrRequest -> (XhrResponse -> IO a) -> IO XMLHttpRequest
50+newXMLHttpRequest req cb = do
51+ xhr <- xmlHttpRequestNew
52+ let c = _xhrRequest_config req
53+ xmlHttpRequestOpen
54+ xhr
55+ (_xhrRequest_method req)
56+ (_xhrRequest_url req)
57+ True
58+ (fromMaybe "" $ _xhrRequestConfig_user c)
59+ (fromMaybe "" $ _xhrRequestConfig_password c)
60+ iforM (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
61+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . toJSString) (_xhrRequestConfig_responseType c)
62+ xmlHttpRequestOnreadystatechange xhr $ do
63+ readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
64+ if readyState == 4
65+ then do
66+ r <- liftIO $ xmlHttpRequestGetResponseText xhr
67+ _ <- liftIO $ cb $ XhrResponse r
68+ return ()
69+ else return ()
70+ _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
71+ return xhr
72+
73+performRequestAsync :: MonadWidget t m => Event t XhrRequest -> m (Event t XhrResponse)
74+performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
75+ liftIO $ newXMLHttpRequest r cb
76+ return ()
77+#endif