@@ -0,0 +1,84 @@
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}
2+
3+module Reflex.Dom.WebSocket.Foreign where
4+
5+import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
6+
7+import Control.Exception
8+import Control.Monad.State
9+import Data.ByteString (ByteString)
10+import Data.Text.Encoding
11+import Foreign.Marshal hiding (void)
12+import Foreign.Ptr
13+import Foreign.Storable
14+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
15+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
16+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
17+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
18+import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
19+import Graphics.UI.Gtk.WebKit.WebView
20+import qualified Data.ByteString as BS
21+import qualified Data.Text as T
22+
23+import Reflex.Dom.Internal.Foreign
24+
25+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
46+newWebSocket wv url onMessage onClose = do
47+ c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv
48+ url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url
49+ newWSArgs <- toJSObject c [url']
50+ newWS <- jsstringcreatewithutf8cstring "(function(that) { var ws = new WebSocket(that[0]); ws['binaryType'] = 'arraybuffer'; return ws; })(this)"
51+ ws <- jsevaluatescript c newWS newWSArgs nullPtr 1 nullPtr
52+ onMessage' <- wrapper $ \_ _ _ _ args _ -> do
53+ e <- peekElemOff args 0
54+ dataProp <- jsstringcreatewithutf8cstring "data"
55+ msg <- jsobjectgetproperty c e dataProp nullPtr
56+ msg' <- fromJSStringMaybe c msg
57+ case msg' of
58+ Nothing -> return ()
59+ Just m -> onMessage $ encodeUtf8 $ T.pack m
60+ jsvaluemakeundefined c
61+ onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'
62+ onClose' <- wrapper $ \_ _ _ _ _ _ -> do
63+ onClose
64+ jsvaluemakeundefined c
65+ onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'
66+ o <- toJSObject c [ws, onMessageCb, onCloseCb]
67+ addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onclose'] = this[2];"
68+ _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr
69+ return $ JSWebSocket ws c
70+
71+webSocketSend :: JSWebSocket -> ByteString -> IO ()
72+webSocketSend (JSWebSocket ws c) bs = do
73+ elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x
74+ let numElems = length elems
75+ bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do
76+ pokeArray elemsArr elems
77+ a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr
78+ newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
79+ jsevaluatescript c newUint8Array a nullPtr 1 nullPtr
80+ send <- jsstringcreatewithutf8cstring "this[0]['send'](String['fromCharCode']['apply'](null, this[1]))"
81+ sendArgs <- toJSObject c [ws, bs']
82+ _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr
83+ return ()
84+