git.iko.soy/reflex-dom
on develop help sign in
add Reflex.Dom.Xhr
a6a7bc5ali abrar
reflex-dom.cabal+6
compare with develop
unifiedsplit
@@ -30,6 +30,11 @@ library
30 data-default,
30 data-default,
31 semigroups
31 semigroups
32
32
33+ if impl(ghcjs)
34+ cpp-options: -D__GHCJS__
35+ build-depends:
36+ ghcjs-base
37+
33 exposed-modules:
38 exposed-modules:
34 Reflex.Dom
39 Reflex.Dom
35 Reflex.Dom.Class
40 Reflex.Dom.Class
@@ -37,6 +42,7 @@ library
37 Reflex.Dom.Widget
42 Reflex.Dom.Widget
38 Reflex.Dom.Widget.Basic
43 Reflex.Dom.Widget.Basic
39 Reflex.Dom.Widget.Input
44 Reflex.Dom.Widget.Input
45+ Reflex.Dom.Xhr
40
46
41 other-extensions: TemplateHaskell
47 other-extensions: TemplateHaskell
42 ghc-prof-options: -fprof-auto
48 ghc-prof-options: -fprof-auto
src/Reflex/Dom.hs+2
@@ -1,8 +1,10 @@
1module Reflex.Dom ( module Reflex.Dom.Class
1module Reflex.Dom ( module Reflex.Dom.Class
2 , module Reflex.Dom.Internal
2 , module Reflex.Dom.Internal
3 , module Reflex.Dom.Widget
3 , module Reflex.Dom.Widget
4+ , module Reflex.Dom.Xhr
4 ) where
5 ) where
5
6
6import Reflex.Dom.Class
7import Reflex.Dom.Class
7import Reflex.Dom.Internal
8import Reflex.Dom.Internal
8import Reflex.Dom.Widget
9import Reflex.Dom.Widget
10+import Reflex.Dom.Xhr
src/Reflex/Dom/Xhr.hsnew file+77
@@ -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