6ce4728 · reflex-dom · git.iko.soy

reflex-dom.cabal+1

compare with develop

unifiedsplit

@@ -66,6 +66,7 @@ library

66 Reflex.Dom.Widget.Lazy

67 Reflex.Dom.Widget.Resize

68 Reflex.Dom.Xhr

69+ Reflex.Dom.Location

69 other-modules:

70 other-modules:

70 Reflex.Dom.Internal.Foreign

71 Reflex.Dom.Internal.Foreign

71 Reflex.Dom.WebSocket.Foreign

72 Reflex.Dom.WebSocket.Foreign

src-ghc/Reflex/Dom/Internal/Foreign.hs+17

@@ -13,6 +13,7 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

13import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

14import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

15import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

16+import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

16import Graphics.UI.Gtk.WebKit.WebView

17import Graphics.UI.Gtk.WebKit.WebView

17import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)

18import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)

18import Graphics.UI.Gtk.WebKit.WebSettings

19import Graphics.UI.Gtk.WebKit.WebSettings

@@ -99,3 +100,19 @@ fromJSStringMaybe c t = do

99 peekCString ps

100 peekCString ps

100 return $ Just s

101 return $ Just s

101

102

103+getLocationHost :: WebView -> IO String

104+getLocationHost wv = do

105+ c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

106+ script <- jsstringcreatewithutf8cstring "location.host"

107+ lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

108+ lh' <- fromJSStringMaybe c lh

109+ return $ maybe "" id lh'

110+

111+getLocationProtocol :: WebView -> IO String

112+getLocationProtocol wv = do

113+ c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

114+ script <- jsstringcreatewithutf8cstring "location.protocol"

115+ lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

116+ lp' <- fromJSStringMaybe c lp

117+ return $ maybe "" id lp'

118+

src-ghc/Reflex/Dom/WebSocket/Foreign.hs+8−20

@@ -26,24 +26,8 @@ data JSWebSocket = JSWebSocket { wsValue :: JSValueRef

26 , wsContext :: JSContextRef

27 }

28

29−getLocationHost :: WebView -> IO String

30−getLocationHost wv = do

31− c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

32− script <- jsstringcreatewithutf8cstring "location.host"

33− lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

34− lh' <- fromJSStringMaybe c lh

35− return $ maybe "" id lh'

36−

37−getLocationProtocol :: WebView -> IO String

38−getLocationProtocol wv = do

39− c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

40− script <- jsstringcreatewithutf8cstring "location.protocol"

41− lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

42− lp' <- fromJSStringMaybe c lp

43− return $ maybe "" id lp'

44−

45−newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket

29+newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

46−newWebSocket wv url onMessage onClose = do

30+newWebSocket wv url onMessage onOpen onClose = do

47 c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

31 c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv

48 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url

32 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url

49 newWSArgs <- toJSObject c [url']

33 newWSArgs <- toJSObject c [url']

@@ -59,12 +43,16 @@ newWebSocket wv url onMessage onClose = do

59 Just m -> onMessage $ encodeUtf8 $ T.pack m

43 Just m -> onMessage $ encodeUtf8 $ T.pack m

60 jsvaluemakeundefined c

44 jsvaluemakeundefined c

61 onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'

45 onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'

46+ onOpen' <- wrapper $ \_ _ _ _ _ _ -> do

47+ onOpen

48+ jsvaluemakeundefined c

49+ onOpenCb <- jsobjectmakefunctionwithcallback c nullPtr onOpen'

62 onClose' <- wrapper $ \_ _ _ _ _ _ -> do

50 onClose' <- wrapper $ \_ _ _ _ _ _ -> do

63 onClose

51 onClose

64 jsvaluemakeundefined c

52 jsvaluemakeundefined c

65 onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'

53 onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'

66− o <- toJSObject c [ws, onMessageCb, onCloseCb]

54+ o <- toJSObject c [ws, onMessageCb, onOpenCb, onCloseCb]

67− addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onclose'] = this[2];"

55+ addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"

68 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

56 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

69 return $ JSWebSocket ws c

57 return $ JSWebSocket ws c

70

58

src-ghcjs/Reflex/Dom/Internal/Foreign.hs+18−1

@@ -1,3 +1,20 @@

1−module Reflex.Dom.Internal.Foreign (runWebGUI) where

1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}

2

3+module Reflex.Dom.Internal.Foreign ( runWebGUI

4+ , module Reflex.Dom.Internal.Foreign

5+ ) where

6+

7+import Control.Monad

3import GHCJS.DOM

8import GHCJS.DOM

9+import GHCJS.DOM.Types

10+import GHCJS.Types

11+

12+foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString

13+

14+getLocationHost :: FromJSString r => a -> IO r

15+getLocationHost _ = liftM fromJSString getLocationHost_

16+

17+foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString

18+

19+getLocationProtocol :: FromJSString r => a -> IO r

20+getLocationProtocol _ = liftM fromJSString getLocationProtocol_

src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+4−3

@@ -7,7 +7,7 @@ import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)

7import Data.ByteString (ByteString)

8import qualified Data.ByteString as BS

9import GHCJS.Types

10−import GHCJS.DOM.WebSocket (message, closeEvent)

10+import GHCJS.DOM.WebSocket (message, open, closeEvent)

11import qualified GHCJS.DOM.WebSocket as GD

12import GHCJS.DOM.MessageEvent

13import GHCJS.DOM.EventM (on)

@@ -20,9 +20,10 @@ import GHCJS.Marshal.Pure

20

21data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

22

23−newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket

23+newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

24−newWebSocket _ url onMessage onClose = do

24+newWebSocket _ url onMessage onOpen onClose = do

25 ws <- GD.newWebSocket url (Just [] :: Maybe [String])

26+ _ <- on ws open $ liftIO onOpen

26 GD.setBinaryType ws "arraybuffer"

27 GD.setBinaryType ws "arraybuffer"

27 _ <- on ws message $ do

28 _ <- on ws message $ do

28 e <- ask

29 e <- ask

src/Reflex/Dom.hs+2

@@ -5,6 +5,7 @@ module Reflex.Dom ( module Reflex

5 , module Reflex.Dom.Xhr

6 , module Reflex.Dom.Time

7 , module Reflex.Dom.WebSocket

8+ , module Reflex.Dom.Location

8 ) where

9 ) where

9

10

10import Reflex

11import Reflex

@@ -14,3 +15,4 @@ import Reflex.Dom.Widget

14import Reflex.Dom.Xhr

15import Reflex.Dom.Xhr

15import Reflex.Dom.Time

16import Reflex.Dom.Time

16import Reflex.Dom.WebSocket

17import Reflex.Dom.WebSocket

18+import Reflex.Dom.Location

src/Reflex/Dom/Location.hsnew file+3

@@ -0,0 +1,3 @@

1+module Reflex.Dom.Location (getLocationHost, getLocationProtocol) where

2+

3+import Reflex.Dom.Internal.Foreign

src/Reflex/Dom/WebSocket.hs+7−2

@@ -29,6 +29,7 @@ instance Reflex t => Default (WebSocketConfig t) where

29

30data WebSocket t

31 = WebSocket { _webSocket_recv :: Event t ByteString

32+ , _webSocket_open :: Event t ()

32 }

33 }

33

34

34webSocket :: forall t m. (HasWebView m, MonadWidget t m) => String -> WebSocketConfig t -> m (WebSocket t)

35webSocket :: forall t m. (HasWebView m, MonadWidget t m) => String -> WebSocketConfig t -> m (WebSocket t)

@@ -39,12 +40,16 @@ webSocket url config = do

39 (eRecv, eRecvTriggerRef) <- newEventWithTriggerRef

40 (eRecv, eRecvTriggerRef) <- newEventWithTriggerRef

40 currentSocketRef <- liftIO $ newIORef Nothing

41 currentSocketRef <- liftIO $ newIORef Nothing

41 --TODO: Disconnect if value no longer needed

42 --TODO: Disconnect if value no longer needed

43+ (eOpen, eOpenTriggerRef) <- newEventWithTriggerRef

42 let onMessage :: ByteString -> IO ()

44 let onMessage :: ByteString -> IO ()

43 onMessage m = postGui $ do

45 onMessage m = postGui $ do

44 mt <- readRef eRecvTriggerRef

46 mt <- readRef eRecvTriggerRef

45 forM_ mt $ \t -> runWithActions [t :=> m]

47 forM_ mt $ \t -> runWithActions [t :=> m]

48+ onOpen = postGui $ do

49+ mt <- readRef eOpenTriggerRef

50+ forM_ mt $ \t -> runWithActions [t :=> ()]

46 start = do

51 start = do

47− ws <- liftIO $ newWebSocket wv url onMessage $ do

52+ ws <- liftIO $ newWebSocket wv url onMessage onOpen $ do

48 void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?

53 void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?

49 liftIO $ writeIORef currentSocketRef Nothing

54 liftIO $ writeIORef currentSocketRef Nothing

50 liftIO $ threadDelay 1000000

55 liftIO $ threadDelay 1000000

@@ -58,6 +63,6 @@ webSocket url config = do

58 Nothing -> return () -- Discard --TODO: should we do something better here? probably buffer it, since we handle reconnection logic; how do we verify that the server has received things?

63 Nothing -> return () -- Discard --TODO: should we do something better here? probably buffer it, since we handle reconnection logic; how do we verify that the server has received things?

59 Just ws -> do

64 Just ws -> do

60 liftIO $ webSocketSend ws payload

65 liftIO $ webSocketSend ws payload

61− return $ WebSocket eRecv

66+ return $ WebSocket eRecv eOpen

62

67

63makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig

68makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig

src/Reflex/Dom/Widget/Basic.hs+1−1

@@ -797,7 +797,7 @@ link s = linkClass s ""

797

798button :: MonadWidget t m => String -> m (Event t ())

799button s = do

800− (e, _) <- el' "button" $ text s

800+ (e, _) <- elAttr' "button" (Map.singleton "type" "button") $ text s

801 return $ domEvent Click e

802

803newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }