96b2abe · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Merge remote-tracking branch 'upstream/master' into darwin-depends

96b2abeRyan Trinkle9 years ago

jsaddle-clib/cbits/include/jsaddle.h+1

compare with master

unifiedsplit

@@ -17,6 +17,7 @@ typedef struct app_callbacks {

17 void (* mainActivity_onStop) ();

18 void (* mainActivity_onDestroy) ();

19 void (* mainActivity_onRestart) ();

20+ void (* mainActivity_onNewIntent) (char *, char *);

20 void (* firebaseInstanceIdService_sendRegistrationToServer) (char *);

21 void (* firebaseInstanceIdService_sendRegistrationToServer) (char *);

21} app_callbacks;

22} app_callbacks;

jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hs+16−3

@@ -18,9 +18,9 @@ import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)

18import Data.Default (def, Default)

19import Data.Monoid ((<>))

20import Data.Text (Text)

21−import qualified Data.Text as T

21+import qualified Data.Text.Encoding as T

23−import Foreign.C.String (CString, newCString, peekCString)

23+import Foreign.C.String (CString, newCString)

24import Foreign.Ptr (FunPtr, Ptr)

25import Foreign.Storable (poke)

26import Foreign.Marshal.Utils (new)

@@ -40,6 +40,9 @@ foreign import ccall safe "wrapper"

40foreign import ccall safe "wrapper"

41 wrapMessageCallback :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))

43+foreign import ccall safe "wrapper"

44+ wrapMessageCallback2 :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ()))

45+

43foreign import ccall safe "wrapper"

46foreign import ccall safe "wrapper"

44 wrapSyncCallback :: (CString -> IO CString) -> IO (FunPtr (CString -> IO CString))

47 wrapSyncCallback :: (CString -> IO CString) -> IO (FunPtr (CString -> IO CString))

@@ -78,6 +81,7 @@ data AppConfig = AppConfig

78 , _appConfig_mainActivityOnStop :: IO ()

81 , _appConfig_mainActivityOnStop :: IO ()

79 , _appConfig_mainActivityOnDestroy :: IO ()

82 , _appConfig_mainActivityOnDestroy :: IO ()

80 , _appConfig_mainActivityOnRestart :: IO ()

83 , _appConfig_mainActivityOnRestart :: IO ()

84+ , _appConfig_mainActivityOnNewIntent :: (Text -> Text -> IO ())

81 , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO ()

85 , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO ()

82 }

86 }

@@ -90,6 +94,7 @@ instance Default AppConfig where

90 , _appConfig_mainActivityOnStop = return ()

94 , _appConfig_mainActivityOnStop = return ()

91 , _appConfig_mainActivityOnDestroy = return ()

95 , _appConfig_mainActivityOnDestroy = return ()

92 , _appConfig_mainActivityOnRestart = return ()

96 , _appConfig_mainActivityOnRestart = return ()

97+ , _appConfig_mainActivityOnNewIntent = \_ _ -> return ()

93 , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer = \_ -> return ()

98 , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer = \_ -> return ()

94 }

99 }

100

@@ -102,8 +107,12 @@ appConfigToAppCallbacks c = do

102 stop <- wrapStartCallback $ _appConfig_mainActivityOnStop c

107 stop <- wrapStartCallback $ _appConfig_mainActivityOnStop c

103 destroy <- wrapStartCallback $ _appConfig_mainActivityOnDestroy c

108 destroy <- wrapStartCallback $ _appConfig_mainActivityOnDestroy c

104 restart <- wrapStartCallback $ _appConfig_mainActivityOnRestart c

109 restart <- wrapStartCallback $ _appConfig_mainActivityOnRestart c

110+ newIntent <- wrapMessageCallback2 $ \intentAction intentData -> do

111+ intentAction' <- fromUtf8CString intentAction

112+ intentData' <- fromUtf8CString intentData

113+ _appConfig_mainActivityOnNewIntent c intentAction' intentData'

105 firebaseRegPtr <- wrapMessageCallback $ \token -> do

114 firebaseRegPtr <- wrapMessageCallback $ \token -> do

106− token' <- T.pack <$> peekCString token

115+ token' <- fromUtf8CString token

107 _appConfig_firebaseInstanceIdServiceSendRegistrationToServer c token'

116 _appConfig_firebaseInstanceIdServiceSendRegistrationToServer c token'

108 return $ AppCallbacks

117 return $ AppCallbacks

109 { _appCallbacks_mainActivity_onCreate = create

118 { _appCallbacks_mainActivity_onCreate = create

@@ -113,9 +122,13 @@ appConfigToAppCallbacks c = do

113 , _appCallbacks_mainActivity_onStop = stop

122 , _appCallbacks_mainActivity_onStop = stop

114 , _appCallbacks_mainActivity_onDestroy = destroy

123 , _appCallbacks_mainActivity_onDestroy = destroy

115 , _appCallbacks_mainActivity_onRestart = restart

124 , _appCallbacks_mainActivity_onRestart = restart

125+ , _appCallbacks_mainActivity_onNewIntent = newIntent

116 , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer = firebaseRegPtr

126 , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer = firebaseRegPtr

117 }

127 }

118

128

129+fromUtf8CString :: CString -> IO Text

130+fromUtf8CString = fmap T.decodeUtf8 . packCString

131+

119pokeAppConfig :: Ptr AppCallbacks -> AppConfig -> IO ()

132pokeAppConfig :: Ptr AppCallbacks -> AppConfig -> IO ()

120pokeAppConfig ptr cfg = poke ptr =<< appConfigToAppCallbacks cfg

133pokeAppConfig ptr cfg = poke ptr =<< appConfigToAppCallbacks cfg

121

134

jsaddle-clib/src/Language/Javascript/JSaddle/CLib/Internal.hsc+3

@@ -38,6 +38,7 @@ data AppCallbacks = AppCallbacks

38 , _appCallbacks_mainActivity_onStop :: !(FunPtr (IO ()))

39 , _appCallbacks_mainActivity_onDestroy :: !(FunPtr (IO ()))

40 , _appCallbacks_mainActivity_onRestart :: !(FunPtr (IO ()))

41+ , _appCallbacks_mainActivity_onNewIntent :: !(FunPtr (CString -> CString -> IO ()))

41 , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer :: !(FunPtr (CString -> IO ()))

42 , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer :: !(FunPtr (CString -> IO ()))

42 }

43 }

@@ -52,6 +53,7 @@ instance Storable AppCallbacks where

52 #{poke app_callbacks, mainActivity_onStop} p $ _appCallbacks_mainActivity_onStop nc

53 #{poke app_callbacks, mainActivity_onStop} p $ _appCallbacks_mainActivity_onStop nc

53 #{poke app_callbacks, mainActivity_onDestroy} p $ _appCallbacks_mainActivity_onDestroy nc

54 #{poke app_callbacks, mainActivity_onDestroy} p $ _appCallbacks_mainActivity_onDestroy nc

54 #{poke app_callbacks, mainActivity_onRestart} p $ _appCallbacks_mainActivity_onRestart nc

55 #{poke app_callbacks, mainActivity_onRestart} p $ _appCallbacks_mainActivity_onRestart nc

56+ #{poke app_callbacks, mainActivity_onNewIntent} p $ _appCallbacks_mainActivity_onNewIntent nc

55 #{poke app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p $ _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer nc

57 #{poke app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p $ _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer nc

56 peek p = AppCallbacks

58 peek p = AppCallbacks

57 <$> #{peek app_callbacks, mainActivity_onCreate} p

59 <$> #{peek app_callbacks, mainActivity_onCreate} p

@@ -61,4 +63,5 @@ instance Storable AppCallbacks where

61 <*> #{peek app_callbacks, mainActivity_onStop} p

63 <*> #{peek app_callbacks, mainActivity_onStop} p

62 <*> #{peek app_callbacks, mainActivity_onDestroy} p

64 <*> #{peek app_callbacks, mainActivity_onDestroy} p

63 <*> #{peek app_callbacks, mainActivity_onRestart} p

65 <*> #{peek app_callbacks, mainActivity_onRestart} p

66+ <*> #{peek app_callbacks, mainActivity_onNewIntent} p

64 <*> #{peek app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p

67 <*> #{peek app_callbacks, firebaseInstanceIdService_sendRegistrationToServer} p

jsaddle-warp/default.nix+13−12

@@ -1,22 +1,23 @@

1{ mkDerivation, aeson, base, bytestring, containers, deepseq

2−, doctest, filepath, ghc-prim, http-types, jsaddle, lens, primitive

2+, doctest, filepath, foreign-store, ghc-prim, http-types, jsaddle

3−, process, QuickCheck, ref-tf, stdenv, stm, text, time

3+, lens, network, primitive, process, QuickCheck, ref-tf, stdenv

4+, stm, text, time, transformers, uuid, uuid-types, wai

4−, transformers, wai, wai-websockets, warp, websockets

5+, wai-websockets, warp, webdriver, websockets

5−, darwin, webdriver, phantomjs, ghc

6}:

7mkDerivation {

8 pname = "jsaddle-warp";

9− version = "0.9.0.0";

9+ version = "0.9.2.0";

10 src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

11 libraryHaskellDepends = [

12− aeson base containers http-types jsaddle stm text time transformers

12+ aeson base bytestring containers foreign-store http-types jsaddle

13− wai wai-websockets warp websockets

13+ stm text time transformers uuid uuid-types wai wai-websockets warp

14− ] ++ (if ghc.isGhcjs or false then [

14+ websockets

15− ] else [

16− ]);

15+ ];

17 testHaskellDepends = [

16 testHaskellDepends = [

18− base bytestring deepseq doctest filepath ghc-prim jsaddle lens

17+ aeson base bytestring containers deepseq doctest filepath ghc-prim

19− primitive process QuickCheck ref-tf webdriver phantomjs

18+ http-types jsaddle lens network primitive process QuickCheck ref-tf

19+ stm text time transformers wai wai-websockets warp webdriver

20+ websockets

20 ];

21 ];

21 testTarget = "--test-option=${jsaddle.src}";

22 testTarget = "--test-option=${jsaddle.src}";

22 description = "Interface for JavaScript that works with GHCJS and GHC";

23 description = "Interface for JavaScript that works with GHCJS and GHC";

jsaddle-warp/jsaddle-warp.cabal+6−2

@@ -1,5 +1,5 @@

1name: jsaddle-warp

2−version: 0.9.0.0

2+version: 0.9.2.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -26,13 +26,17 @@ library

26 Language.Javascript.JSaddle.WebSockets

27 build-depends:

28 aeson >=0.8.0.2 && <1.3,

29+ bytestring >=0.10.6.0 && <0.11,

29 containers >=0.5.6.2 && <0.6,

30 containers >=0.5.6.2 && <0.6,

31+ foreign-store >=0.2 && <0.3,

30 http-types >=0.8.6 && <0.10,

32 http-types >=0.8.6 && <0.10,

31− jsaddle >=0.9.0.0 && <0.10,

33+ jsaddle >=0.9.2.0 && <0.10,

32 stm >=2.4.4 && <2.5,

34 stm >=2.4.4 && <2.5,

33 text >=1.2.1.3 && <1.3,

35 text >=1.2.1.3 && <1.3,

34 time >=1.5.0.1 && <1.8,

36 time >=1.5.0.1 && <1.8,

35 transformers >=0.4.2.0 && <0.6,

37 transformers >=0.4.2.0 && <0.6,

38+ uuid >=1.3.13 && <1.4,

39+ uuid-types >=1.0.3 && <1.1,

36 wai >=3.0.3.0 && <3.3,

40 wai >=3.0.3.0 && <3.3,

37 wai-websockets >=3.0.0.6 && <3.1,

41 wai-websockets >=3.0.0.6 && <3.1,

38 warp >=3.1.2 && <3.3,

42 warp >=3.1.2 && <3.3,

jsaddle-warp/src/Language/Javascript/JSaddle/Warp.hs+3−4

@@ -17,8 +17,7 @@ module Language.Javascript.JSaddle.Warp (

17 -- * Running JSM over WebSockets

18 run

19#ifndef ghcjs_HOST_OS

20− , jsaddleOr

20+ , module Language.Javascript.JSaddle.WebSockets

21− , jsaddleApp

22#endif

21#endif

23) where

22) where

@@ -29,7 +28,7 @@ import Network.WebSockets (defaultConnectionOptions)

30import Language.Javascript.JSaddle.Types (JSM)

29import Language.Javascript.JSaddle.Types (JSM)

31import Language.Javascript.JSaddle.Run (syncPoint)

30import Language.Javascript.JSaddle.Run (syncPoint)

32−import Language.Javascript.JSaddle.WebSockets (jsaddleOr, jsaddleApp)

31+import Language.Javascript.JSaddle.WebSockets

33#endif

32#endif

35-- | Run the given 'JSM' action as the main entry point. Either directly

34-- | Run the given 'JSM' action as the main entry point. Either directly

@@ -40,6 +39,6 @@ run _port = id

40#else

39#else

41run :: Int -> JSM () -> IO ()

40run :: Int -> JSM () -> IO ()

42run port f =

41run port f =

43− runSettings (setPort port (setTimeout 3600 defaultSettings)) $

42+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<

44 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp

43 jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp

45#endif

44#endif

jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+212−55

@@ -1,5 +1,7 @@

1{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE RecursiveDo #-}

3-----------------------------------------------------------------------------

5-----------------------------------------------------------------------------

4--

6--

5-- Module : Language.Javascript.JSaddle.WebSockets

7-- Module : Language.Javascript.JSaddle.WebSockets

@@ -16,73 +18,228 @@ module Language.Javascript.JSaddle.WebSockets (

16 -- * Running JSM over WebSockets

18 -- * Running JSM over WebSockets

17 jsaddleOr

19 jsaddleOr

18 , jsaddleApp

20 , jsaddleApp

21+ , jsaddleWithAppOr

22+ , jsaddleAppPartial

23+ , debug

24+ , debugWrapper

19) where

25) where

21−import Control.Monad (forever)

27+import Control.Monad (when, join, void, forever)

22−import Control.Concurrent (forkIO, threadDelay)

28+import Control.Concurrent (killThread, forkIO, threadDelay)

23−import Control.Exception (handle, AsyncException, throwIO, fromException)

29+import Control.Exception (handle, AsyncException, throwIO, fromException, finally)

25import Data.Monoid ((<>))

31import Data.Monoid ((<>))

26import Data.Aeson (encode, decode)

32import Data.Aeson (encode, decode)

28−import Network.Wai (Application)

34+import Network.Wai

35+ (Middleware, lazyRequestBody, Application, Request, Response,

36+ ResponseReceived)

29import Network.WebSockets

37import Network.WebSockets

30− (ConnectionOptions(..), sendTextData, receiveDataMessage,

38+ (defaultConnectionOptions, ConnectionOptions(..), sendTextData,

31− acceptRequest, ServerApp, sendPing)

39+ receiveDataMessage, acceptRequest, ServerApp, sendPing)

32import qualified Network.WebSockets as WS (DataMessage(..))

40import qualified Network.WebSockets as WS (DataMessage(..))

33import Network.Wai.Handler.WebSockets (websocketsOr)

41import Network.Wai.Handler.WebSockets (websocketsOr)

35−import Language.Javascript.JSaddle.Types (JSM(..))

43+import Language.Javascript.JSaddle.Types (JSM(..), JSContextRef(..))

36import qualified Network.Wai as W

44import qualified Network.Wai as W

37− (responseLBS, requestMethod, Application, pathInfo)

45+ (responseLBS, requestMethod, pathInfo)

38−import Data.Text (Text)

39import qualified Data.Text as T (pack)

46import qualified Data.Text as T (pack)

40import qualified Network.HTTP.Types as H

47import qualified Network.HTTP.Types as H

41− (status403, status200, status405)

48+ (status403, status200)

42−import Language.Javascript.JSaddle.Run (runJavaScript)

49+import Language.Javascript.JSaddle.Run (syncPoint, runJavaScript)

43−import Language.Javascript.JSaddle.Run.Files (indexHtml, jsaddleJs)

50+import Language.Javascript.JSaddle.Run.Files (indexHtml, runBatch, ghcjsHelpers, initState)

44−

51+import Language.Javascript.JSaddle.Debug

52+ (removeContext, addContext)

53+import Data.Maybe (fromMaybe)

54+import qualified Data.Map as M (empty, insert, lookup)

55+import Data.IORef

56+ (writeIORef, IORef, readIORef, newIORef, atomicModifyIORef')

57+import Data.ByteString.Lazy (ByteString)

58+import Data.UUID.Types (toText)

59+import Control.Concurrent.MVar

60+ (tryPutMVar, modifyMVar_, putMVar, takeMVar, readMVar, newMVar,

61+ newEmptyMVar, modifyMVar)

62+import Network.Wai.Handler.Warp

63+ (defaultSettings, setTimeout, setPort, runSettings)

64+import Foreign.Store (newStore, readStore, lookupStore)

65+import Language.Javascript.JSaddle (askJSM)

66+import Control.Monad.IO.Class (MonadIO(..))

67+

45−jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application

68+jsaddleOr :: ConnectionOptions -> JSM () -> Application -> IO Application

46−jsaddleOr opts entryPoint = websocketsOr opts wsApp

69+jsaddleOr opts entryPoint otherApp = do

47− where

70+ syncHandlers <- newIORef M.empty

48− wsApp :: ServerApp

71+ let wsApp :: ServerApp

49− wsApp pending_conn = do

72+ wsApp pending_conn = do

50− conn <- acceptRequest pending_conn

73+ conn <- acceptRequest pending_conn

51− (processResult, _, start) <- runJavaScript (sendTextData conn . encode) entryPoint

74+ rec (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) $ do

75+ syncKey <- toText . contextId <$> askJSM

76+ liftIO $ atomicModifyIORef' syncHandlers (\m -> (M.insert syncKey processSyncResult m, ()))

77+ liftIO $ sendTextData conn (encode syncKey)

78+ entryPoint

52− _ <- forkIO . forever $

79+ _ <- forkIO . forever $

53− receiveDataMessage conn >>= \case

80+ receiveDataMessage conn >>= \case

54− (WS.Text t) ->

81+ (WS.Text t) ->

55− case decode t of

82+ case decode t of

56− Nothing -> error $ "jsaddle Results decode failed : " <> show t

83+ Nothing -> error $ "jsaddle Results decode failed : " <> show t

57− Just r -> processResult r

84+ Just r -> processResult r

58− _ -> error "jsaddle WebSocket unexpected binary data"

85+ _ -> error "jsaddle WebSocket unexpected binary data"

59− start

86+ start

60− waitTillClosed conn

87+ waitTillClosed conn

61−

88+

62− -- Based on Network.WebSocket.forkPingThread

89+ -- Based on Network.WebSocket.forkPingThread

63− waitTillClosed conn = ignore `handle` go 1

90+ waitTillClosed conn = ignore `handle` go 1

64− where

91+ where

65− go :: Int -> IO ()

92+ go :: Int -> IO ()

66− go i = do

93+ go i = do

67− threadDelay (1 * 1000 * 1000)

94+ threadDelay (1 * 1000 * 1000)

68− sendPing conn (T.pack $ show i)

95+ sendPing conn (T.pack $ show i)

69− go (i + 1)

96+ go (i + 1)

70−

97+

71− ignore e = case fromException e of

98+ ignore e = case fromException e of

72− Just async -> throwIO (async :: AsyncException)

99+ Just async -> throwIO (async :: AsyncException)

73− Nothing -> return ()

100+ Nothing -> return ()

101+

102+ syncHandler :: Application

103+ syncHandler req sendResponse = case (W.requestMethod req, W.pathInfo req) of

104+ ("POST", ["sync", syncKey]) -> do

105+ body <- lazyRequestBody req

106+ case decode body of

107+ Nothing -> error $ "jsaddle sync message decode failed : " <> show body

108+ Just result ->

109+ M.lookup syncKey <$> readIORef syncHandlers >>= \case

110+ Nothing -> error "jsaddle missing sync message handler"

111+ Just handler -> do

112+ next <- encode <$> handler result

113+ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] next

114+ _ -> otherApp req sendResponse

115+ return $ websocketsOr opts wsApp syncHandler

116+

117

75jsaddleApp :: Application

118jsaddleApp :: Application

76−jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req

119+jsaddleApp req sendResponse =

77−

120+ fromMaybe

78−jsaddleAppPieces :: [Text] -> W.Application

121+ (sendResponse $ W.responseLBS H.status403 [("Content-Type", "text/plain")] "Forbidden")

79−jsaddleAppPieces _ req sendResponse

122+ (jsaddleAppPartial req sendResponse)

80− | W.requestMethod req `notElem` ["GET", "HEAD"] = sendResponse $ W.responseLBS

123+

81− H.status405

124+jsaddleWithAppOr :: ConnectionOptions -> JSM () -> Application -> IO Application

82− [("Content-Type", "text/plain")]

125+jsaddleWithAppOr opts entryPoint otherApp = jsaddleOr opts entryPoint $ \req sendResponse ->

83− "Only GET or HEAD is supported"

126+ (fromMaybe (otherApp req sendResponse)

127+ (jsaddleAppPartial req sendResponse))

128+

129+jsaddleAppPartial :: Request -> (Response -> IO ResponseReceived) -> Maybe (IO ResponseReceived)

130+jsaddleAppPartial req sendResponse = case (W.requestMethod req, W.pathInfo req) of

84−jsaddleAppPieces [] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml

131+ ("GET", []) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] indexHtml

85−jsaddleAppPieces ["jsaddle.js"] _req sendResponse = sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs

132+ ("GET", ["jsaddle.js"]) -> Just $ sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] jsaddleJs

86−jsaddleAppPieces _rawPieces _req sendResponse = sendResponse $ W.responseLBS H.status403

133+ _ -> Nothing

87− [ ("Content-Type", "text/plain")

134+

88− ] "Forbidden"

135+-- Use this to generate this string for embedding

136+-- sed -e 's|\\|\\\\|g' -e 's|^| \\|' -e 's|$|\\n\\|' -e 's|"|\\"|g' data/jsaddle.js | pbcopy

137+jsaddleJs :: ByteString

138+jsaddleJs = "\

139+ \if(typeof global !== \"undefined\") {\n\

140+ \ global.window = global;\n\

141+ \ global.WebSocket = require('ws');\n\

142+ \}\n\

143+ \\n\

144+ \var connect = function() {\n\

145+ \ var wsaddress = window.location.protocol.replace('http', 'ws')+\"//\"+window.location.hostname+(window.location.port?(\":\"+window.location.port):\"\");\n\

146+ \\n\

147+ \ var ws = new WebSocket(wsaddress);\n\

148+ \ var syncKey = \"\";\n\

149+ \\n\

150+ \ ws.onopen = function(e) {\n\

151+ \ " <> initState <> "\n\

152+ \ var inXhrSend = false;\n\

153+ \\n\

154+ \ ws.onmessage = function(e) {\n\

155+ \ if(inXhrSend) return;\n\

156+ \ var batch = JSON.parse(e.data);\n\

157+ \ if(typeof batch === \"string\") {\n\

158+ \ syncKey = batch;\n\

159+ \ var xhr = new XMLHttpRequest();\n\

160+ \ xhr.open('POST', '/reload/'+syncKey, true);\n\

161+ \ xhr.onreadystatechange = function() {\n\

162+ \ if(xhr.readyState === XMLHttpRequest.DONE && xhr.status === 200)\n\

163+ \ setTimeout(function(){window.location.reload();}, 500);\n\

164+ \ };\n\

165+ \ xhr.send();\n\

166+ \ return;\n\

167+ \ }\n\

168+ \\n\

169+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));")

170+ (Just (\a -> "(function(){\n\

171+ \ inXhrSend = true;\n\

172+ \ var xhr = new XMLHttpRequest();\n\

173+ \ xhr.open('POST', '/sync/'+syncKey, false);\n\

174+ \ xhr.setRequestHeader(\"Content-type\", \"application/json\");\n\

175+ \ xhr.send(JSON.stringify(" <> a <> "));\n\

176+ \ inXhrSend = false;\n\

177+ \ return JSON.parse(xhr.response);})()")) <> "\

178+ \ };\n\

179+ \ };\n\

180+ \ ws.onerror = function() {\n\

181+ \ setTimeout(connect, 1000);\n\

182+ \ };\n\

183+ \}\n\

184+ \\n\

185+ \ " <> ghcjsHelpers <> "\

186+ \connect();\n\

187+ \"

188+

189+-- | Start or restart the server.

190+-- To run this as part of every :reload use

191+-- > :def! reload (const $ return "::reload\nLanguage.Javascript.JSaddle.Warp.debug 3708 SomeMainModule.someMainFunction")

192+debug :: Int -> JSM () -> IO ()

193+debug port f = do

194+ debugWrapper $ \refreshMiddleware registerContext ->

195+ runSettings (setPort port (setTimeout 3600 defaultSettings)) =<<

196+ jsaddleOr defaultConnectionOptions (registerContext >> f >> syncPoint) (refreshMiddleware jsaddleApp)

197+ putStrLn $ "<a href=\"http://localhost:" <> show port <> "\">run</a>"

198+

199+debugWrapper :: (Middleware -> JSM () -> IO ()) -> IO ()

200+debugWrapper run = do

201+ reloadMVar <- newEmptyMVar

202+ reloadDoneMVars <- newMVar []

203+ contexts <- newMVar []

204+ let refreshMiddleware :: Middleware

205+ refreshMiddleware otherApp req sendResponse = case (W.requestMethod req, W.pathInfo req) of

206+ ("POST", ["reload", _syncKey]) -> do

207+ reloadDone <- newEmptyMVar

208+ modifyMVar_ reloadDoneMVars (return . (reloadDone:))

209+ readMVar reloadMVar

210+ r <- sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/json")] ("reload" :: ByteString)

211+ putMVar reloadDone ()

212+ return r

213+ _ -> otherApp req sendResponse

214+ start :: Int -> IO (IO Int)

215+ start expectedConnections = do

216+ serverDone <- newEmptyMVar

217+ ready <- newEmptyMVar

218+ let registerContext :: JSM ()

219+ registerContext = do

220+ uuid <- contextId <$> askJSM

221+ browsersConnected <- liftIO $ modifyMVar contexts (\ctxs -> return (uuid:ctxs, length ctxs + 1))

222+ addContext

223+ when (browsersConnected == expectedConnections) . void . liftIO $ tryPutMVar ready ()

224+ thread <- forkIO $

225+ finally (run refreshMiddleware registerContext)

226+ (putMVar serverDone ())

227+ _ <- forkIO $ threadDelay 10000000 >> void (tryPutMVar ready ())

228+ when (expectedConnections /= 0) $ takeMVar ready

229+ return $ do

230+ putMVar reloadMVar ()

231+ ctxs <- takeMVar contexts

232+ mapM_ removeContext ctxs

233+ takeMVar reloadDoneMVars >>= mapM_ takeMVar

234+ killThread thread

235+ takeMVar serverDone

236+ return $ length ctxs

237+ lookupStore shutdown_0 >>= \case

238+ Nothing -> do

239+ shutdownRef <- newIORef =<< start 0

240+ void $ newStore shutdownRef

241+ Just shutdownStore -> do

242+ shutdownRef :: IORef (IO Int) <- readStore shutdownStore

243+ expectedConnections <- join (readIORef shutdownRef)

244+ writeIORef shutdownRef =<< start expectedConnections

245+ where shutdown_0 = 0

jsaddle-wkwebview/cbits-uikit/AppDelegate.m+13

@@ -19,6 +19,7 @@ HsStablePtr global_applicationDidEnterBackground = 0;

19HsStablePtr global_applicationWillEnterForeground = 0;

20HsStablePtr global_applicationWillTerminate = 0;

21HsStablePtr global_applicationSignificantTimeChange = 0;

22+HsStablePtr global_applicationUniversalLink = 0;

22uint64_t global_requestAuthorizationWithOptions = 0;

23uint64_t global_requestAuthorizationWithOptions = 0;

23uint64_t global_requestAuthorizationOptionBadge = 0;

24uint64_t global_requestAuthorizationOptionBadge = 0;

24uint64_t global_requestAuthorizationOptionSound = 0;

25uint64_t global_requestAuthorizationOptionSound = 0;

@@ -119,6 +120,16 @@ HsStablePtr global_didFailToRegisterForRemoteNotificationsWithError = 0;

119 callIO(global_applicationSignificantTimeChange);

120 callIO(global_applicationSignificantTimeChange);

120}

121}

121

122

123+- (BOOL)application:(UIApplication *)application continueUserActivity:(NSUserActivity *)userActivity restorationHandler:(void (^)(NSArray *restorableObjects))restorationHandler {

124+ // TODO: Reroute universal links when they're clicked in-app.

125+ // https://developer.apple.com/reference/webkit/wknavigationdelegate/1455643-webview?language=objc

126+ if ([userActivity.activityType isEqualToString:NSUserActivityTypeBrowsingWeb] && userActivity.webpageURL) {

127+ callWithCString([userActivity.webpageURL.absoluteString UTF8String], global_applicationUniversalLink);

128+ return YES;

129+ }

130+ return NO;

131+}

132+

122@end

133@end

123

134

124void runInWKWebView(HsStablePtr handler,

135void runInWKWebView(HsStablePtr handler,

@@ -131,6 +142,7 @@ void runInWKWebView(HsStablePtr handler,

131 HsStablePtr hs_applicationWillEnterForeground,

142 HsStablePtr hs_applicationWillEnterForeground,

132 HsStablePtr hs_applicationWillTerminate,

143 HsStablePtr hs_applicationWillTerminate,

133 HsStablePtr hs_applicationSignificantTimeChange,

144 HsStablePtr hs_applicationSignificantTimeChange,

145+ HsStablePtr hs_applicationUniversalLink,

134 const uint64_t hs_requestAuthorizationWithOptions,

146 const uint64_t hs_requestAuthorizationWithOptions,

135 const uint64_t hs_requestAuthorizationOptionBadge,

147 const uint64_t hs_requestAuthorizationOptionBadge,

136 const uint64_t hs_requestAuthorizationOptionSound,

148 const uint64_t hs_requestAuthorizationOptionSound,

@@ -149,6 +161,7 @@ void runInWKWebView(HsStablePtr handler,

149 global_applicationWillEnterForeground = hs_applicationWillEnterForeground;

161 global_applicationWillEnterForeground = hs_applicationWillEnterForeground;

150 global_applicationWillTerminate = hs_applicationWillTerminate;

162 global_applicationWillTerminate = hs_applicationWillTerminate;

151 global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;

163 global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;

164+ global_applicationUniversalLink = hs_applicationUniversalLink;

152 global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;

165 global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;

153 global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;

166 global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;

154 global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;

167 global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;

jsaddle-wkwebview/src-ghc/Language/Javascript/JSaddle/WKWebView.hs+5

@@ -34,6 +34,7 @@ foreign import ccall runInWKWebView

34 -> StablePtr (IO ()) -- applicationWillEnterForeground

35 -> StablePtr (IO ()) -- applicationWillTerminate

36 -> StablePtr (IO ()) -- applicationSignificantTimeChange

37+ -> StablePtr (CString -> IO ()) -- applicationUniversalLink

37 -> Word64 -- whether to run requestAuthorizationWithOptions

38 -> Word64 -- whether to run requestAuthorizationWithOptions

38 -> Word64 -- Ask for Badge authorization

39 -> Word64 -- Ask for Badge authorization

39 -> Word64 -- Ask for Sound authorization

40 -> Word64 -- Ask for Sound authorization

@@ -53,6 +54,7 @@ data AppDelegateConfig = AppDelegateConfig

53 , _appDelegateConfig_applicationWillEnterForeground :: IO ()

54 , _appDelegateConfig_applicationWillEnterForeground :: IO ()

54 , _appDelegateConfig_applicationWillTerminate :: IO ()

55 , _appDelegateConfig_applicationWillTerminate :: IO ()

55 , _appDelegateConfig_applicationSignificantTimeChange :: IO ()

56 , _appDelegateConfig_applicationSignificantTimeChange :: IO ()

57+ , _appDelegateConfig_applicationUniversalLink :: CString -> IO ()

56 , _appDelegateConfig_appDelegateNotificationConfig :: AppDelegateNotificationConfig

58 , _appDelegateConfig_appDelegateNotificationConfig :: AppDelegateNotificationConfig

57 }

59 }

@@ -66,6 +68,7 @@ instance Default AppDelegateConfig where

66 , _appDelegateConfig_applicationWillEnterForeground = return ()

68 , _appDelegateConfig_applicationWillEnterForeground = return ()

67 , _appDelegateConfig_applicationWillTerminate = return ()

69 , _appDelegateConfig_applicationWillTerminate = return ()

68 , _appDelegateConfig_applicationSignificantTimeChange = return ()

70 , _appDelegateConfig_applicationSignificantTimeChange = return ()

71+ , _appDelegateConfig_applicationUniversalLink = \_ -> return ()

69 , _appDelegateConfig_appDelegateNotificationConfig = def

72 , _appDelegateConfig_appDelegateNotificationConfig = def

70 }

73 }

@@ -127,6 +130,7 @@ run' mUrl cfg f = do

127 applicationWillEnterForeground <- newStablePtr $ _appDelegateConfig_applicationWillEnterForeground cfg

130 applicationWillEnterForeground <- newStablePtr $ _appDelegateConfig_applicationWillEnterForeground cfg

128 applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg

131 applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg

129 applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg

132 applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg

133+ applicationUniversalLink <- newStablePtr $ _appDelegateConfig_applicationUniversalLink cfg

130

134

131 -- AppDelegate notification configuration

135 -- AppDelegate notification configuration

132 let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg

136 let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg

@@ -148,6 +152,7 @@ run' mUrl cfg f = do

148 applicationWillEnterForeground

152 applicationWillEnterForeground

149 applicationWillTerminate

153 applicationWillTerminate

150 applicationSignificantTimeChange

154 applicationSignificantTimeChange

155+ applicationUniversalLink

151 (fromBool requestAuthorizationWithOptions)

156 (fromBool requestAuthorizationWithOptions)

152 (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)

157 (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)

153 (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)

158 (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)

jsaddle/default.nix+2−1

@@ -1,7 +1,7 @@

1{ mkDerivation, aeson, attoparsec, base, base64-bytestring

2, bytestring, containers, deepseq, filepath, ghc-prim, http-types

3, lens, primitive, process, ref-tf, scientific, stdenv, stm, text

4−, time, transformers, unordered-containers, vector

4+, time, transformers, unordered-containers, vector, uuid, uuid-types

5}:

6mkDerivation {

7 pname = "jsaddle";

@@ -11,6 +11,7 @@ mkDerivation {

11 aeson attoparsec base base64-bytestring bytestring containers

12 deepseq filepath ghc-prim http-types lens primitive process ref-tf

13 scientific stm text time transformers unordered-containers vector

14+ uuid uuid-types

14 ];

15 ];

15 description = "Interface for JavaScript that works with GHCJS and GHC";

16 description = "Interface for JavaScript that works with GHCJS and GHC";

16 license = stdenv.lib.licenses.mit;

17 license = stdenv.lib.licenses.mit;

jsaddle/jsaddle.cabal+5−1

@@ -1,5 +1,5 @@

1name: jsaddle

2−version: 0.9.0.0

2+version: 0.9.2.1

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -47,6 +47,8 @@ library

47 stm >=2.4.4 && <2.5,

48 time >=1.5.0.1 && <1.8,

49 unordered-containers >=0.2 && <0.3,

50+ uuid >=1.3.13 && <1.4,

51+ uuid-types >=1.0.3 && <1.1,

50 vector >=0.10 && <0.13

52 vector >=0.10 && <0.13

51 exposed-modules:

53 exposed-modules:

52 Data.JSString

54 Data.JSString

@@ -81,8 +83,10 @@ library

81 JavaScript.Array.Internal

83 JavaScript.Array.Internal

82 JavaScript.Object

84 JavaScript.Object

83 JavaScript.Object.Internal

85 JavaScript.Object.Internal

86+ Language.Javascript.JSaddle.Debug

84 Language.Javascript.JSaddle.Native

87 Language.Javascript.JSaddle.Native

85 Language.Javascript.JSaddle.Native.Internal

88 Language.Javascript.JSaddle.Native.Internal

89+ Language.Javascript.JSaddle.Null

86 hs-source-dirs: src-ghc

90 hs-source-dirs: src-ghc

87 exposed-modules:

91 exposed-modules:

88 Language.Javascript.JSaddle

92 Language.Javascript.JSaddle

jsaddle/src/Language/Javascript/JSaddle/Debug.hsnew file+48

@@ -0,0 +1,48 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+-----------------------------------------------------------------------------

4+--

5+-- Module : Language.Javascript.JSaddle.WebSockets

6+-- Copyright : (c) Hamish Mackenzie

7+-- License : MIT

8+--

9+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.Javascript.JSaddle.Debug (

16+ contexts

17+ , addContext

18+ , removeContext

19+ , runOnAll

20+ , runOnAll_

21+) where

22+

23+import Language.Javascript.JSaddle

24+ (runJSM, askJSM, JSM, JSContextRef(..))

25+import Data.IORef (readIORef, atomicModifyIORef', newIORef, IORef)

26+import System.IO.Unsafe (unsafePerformIO)

27+import Data.Monoid ((<>))

28+import Control.Monad.IO.Class (MonadIO(..))

29+import Data.UUID (UUID)

30+

31+contexts :: IORef [JSContextRef]

32+contexts = unsafePerformIO $ newIORef []

33+{-# NOINLINE contexts #-}

34+

35+addContext :: JSM ()

36+addContext = do

37+ ctx <- askJSM

38+ liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ())

39+

40+removeContext :: MonadIO m => UUID -> m ()

41+removeContext uuid =

42+ liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= uuid) . contextId) c, ())

43+

44+runOnAll :: MonadIO m => JSM a -> m [a]

45+runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f)

46+

47+runOnAll_ :: MonadIO m => JSM a -> m ()

48+runOnAll_ f = liftIO (readIORef contexts) >>= mapM_ (runJSM f)

jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+3−3

@@ -62,9 +62,9 @@ wrapJSString :: MonadIO m => JSStringReceived -> m JSString

62wrapJSString (JSStringReceived ref) = return $ JSString ref

64withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a

65−withJSVal v@(JSVal ref) f =

65+withJSVal (JSVal ref) f = do

66− do result <- f (JSValueForSend ref)

66+ result <- f (JSValueForSend ref)

67− liftIO $ touch v

67+ liftIO $ touch ref

68 return result

70withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a

jsaddle/src/Language/Javascript/JSaddle/Null.hsnew file+56

@@ -0,0 +1,56 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+-----------------------------------------------------------------------------

4+--

5+-- Module : Language.Javascript.JSaddle.WebSockets

6+-- Copyright : (c) Hamish Mackenzie

7+-- License : MIT

8+--

9+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.Javascript.JSaddle.Null (

16+ run

17+) where

18+

19+import Language.Javascript.JSaddle.Types

20+ (BatchResults(..), JSM, JSStringReceived(..), Batch(..),

21+ Results(..), Result(..), Command(..))

22+import Control.Concurrent.Chan (readChan, writeChan, newChan)

23+import Language.Javascript.JSaddle.Run (runJavaScript)

24+import Control.Concurrent (forkIO)

25+import Control.Monad (forever)

26+import Data.Aeson (Value(..))

27+import Data.Maybe (mapMaybe)

28+

29+-- | This is for performance testing JSaddle code that does not need to

30+-- to read anything back from the JavaScript context.

31+-- Anthing that does try to read will get JS null, 0 or "" back (depending

32+-- on how the value is read).

33+run :: JSM () -> IO ()

34+run f = do

35+ batches <- newChan

36+ (processResult, _processSyncResult, start) <- runJavaScript (writeChan batches) f

37+ _ <- forkIO $ forever $

38+ readChan batches >>= \case

39+ Batch commands _ batchNumber ->

40+ processResult $ BatchResults batchNumber . Success $ mapMaybe (\case

41+ Left _ -> Nothing

42+ Right command -> Just $

43+ case command of

44+ DeRefVal _ -> DeRefValResult 0 ""

45+ ValueToBool _ -> ValueToBoolResult False

46+ ValueToNumber _ -> ValueToNumberResult 0

47+ ValueToString _ -> ValueToStringResult (JSStringReceived "")

48+ ValueToJSON _ -> ValueToJSONResult (JSStringReceived "null")

49+ ValueToJSONValue _ -> ValueToJSONValueResult Null

50+ IsNull _ -> IsNullResult True

51+ IsUndefined _ -> IsUndefinedResult False

52+ StrictEqual _ _ -> StrictEqualResult False

53+ InstanceOf _ _ -> InstanceOfResult False

54+ PropertyNames _ -> PropertyNamesResult []

55+ Sync -> SyncResult) commands

56+ start

jsaddle/src/Language/Javascript/JSaddle/Run.hs+38−16

@@ -2,6 +2,8 @@

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE LambdaCase #-}

4{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE MagicHash #-}

6+{-# LANGUAGE UnboxedTuples #-}

5-----------------------------------------------------------------------------

7-----------------------------------------------------------------------------

6--

8--

7-- Module : Language.Javascript.JSaddle.Run

9-- Module : Language.Javascript.JSaddle.Run

@@ -39,25 +41,29 @@ import Language.Javascript.JSaddle.Types (JSM)

39import qualified JavaScript.Web.AnimationFrame as GHCJS

41import qualified JavaScript.Web.AnimationFrame as GHCJS

40 (waitForAnimationFrame)

42 (waitForAnimationFrame)

41#else

43#else

42−import Control.Exception (throwIO)

44+import Control.Exception (throwIO, evaluate)

43−import Control.Monad (void, when, forever, zipWithM_)

45+import Control.Monad (void, when, zipWithM_)

44import Control.Monad.IO.Class (MonadIO(..))

46import Control.Monad.IO.Class (MonadIO(..))

45import Control.Monad.Trans.Reader (ask, runReaderT)

47import Control.Monad.Trans.Reader (ask, runReaderT)

46import Control.Monad.STM (atomically)

48import Control.Monad.STM (atomically)

47−import Control.Concurrent (forkIO)

49+import Control.Concurrent (forkIO, myThreadId)

48import Control.Concurrent.STM.TChan

50import Control.Concurrent.STM.TChan

49 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)

51 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)

50import Control.Concurrent.STM.TVar

52import Control.Concurrent.STM.TVar

51 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)

53 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)

52import Control.Concurrent.MVar

54import Control.Concurrent.MVar

53− (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar, readMVar)

55+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)

55import System.IO.Unsafe (unsafeInterleaveIO)

57import System.IO.Unsafe (unsafeInterleaveIO)

56import System.Mem.Weak (addFinalizer)

58import System.Mem.Weak (addFinalizer)

60+import GHC.Base (IO(..), mkWeak#)

61+import GHC.Conc (ThreadId(..))

58import Data.Monoid ((<>))

62import Data.Monoid ((<>))

59−import qualified Data.Text as T (unpack)

63+import qualified Data.Text as T (unpack, pack)

60import qualified Data.Map as M (lookup, delete, insert, empty, size)

64import qualified Data.Map as M (lookup, delete, insert, empty, size)

65+import qualified Data.Set as S (empty, member, insert, delete)

66+import Data.UUID.V4 (nextRandom)

61import Data.Time.Clock (getCurrentTime,diffUTCTime)

67import Data.Time.Clock (getCurrentTime,diffUTCTime)

62import Data.IORef (newIORef, atomicWriteIORef, readIORef)

68import Data.IORef (newIORef, atomicWriteIORef, readIORef)

@@ -65,11 +71,8 @@ import Language.Javascript.JSaddle.Types

65 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

71 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

66 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))

72 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))

67import Language.Javascript.JSaddle.Exception (JSException(..))

73import Language.Javascript.JSaddle.Exception (JSException(..))

68−-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)

69import Control.DeepSeq (deepseq)

74import Control.DeepSeq (deepseq)

70import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

75import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

71−import Data.Maybe (isJust)

72−import Data.Foldable (forM_)

73#endif

76#endif

75-- | Enable (or disable) JSaddle logging

78-- | Enable (or disable) JSaddle logging

@@ -138,7 +141,7 @@ sendLazyCommand cmd = do

138 nextRefTVar <- nextRef <$> JSM ask

141 nextRefTVar <- nextRef <$> JSM ask

139 n <- liftIO . atomically $ do

142 n <- liftIO . atomically $ do

140 n <- subtract 1 <$> readTVar nextRefTVar

143 n <- subtract 1 <$> readTVar nextRefTVar

141− writeTVar nextRefTVar n

144+ writeTVar nextRefTVar $! n

142 return n

145 return n

143 s <- doSendAsyncCommand <$> JSM ask

146 s <- doSendAsyncCommand <$> JSM ask

144 liftIO $ s (cmd $ JSValueForSend n)

147 liftIO $ s (cmd $ JSValueForSend n)

@@ -151,15 +154,18 @@ sendAsyncCommand cmd = do

151

154

152runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())

155runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())

153runJavaScript sendBatch entryPoint = do

156runJavaScript sendBatch entryPoint = do

157+ contextId' <- nextRandom

154 startTime' <- getCurrentTime

158 startTime' <- getCurrentTime

155 recvMVar <- newEmptyMVar

159 recvMVar <- newEmptyMVar

156 lastAsyncBatch <- newEmptyMVar

160 lastAsyncBatch <- newEmptyMVar

157 commandChan <- newTChanIO

161 commandChan <- newTChanIO

158 callbacks <- newTVarIO M.empty

162 callbacks <- newTVarIO M.empty

159 nextRef' <- newTVarIO 0

163 nextRef' <- newTVarIO 0

164+ finalizerThreads' <- newMVar S.empty

160 loggingEnabled <- newIORef False

165 loggingEnabled <- newIORef False

161 let ctx = JSContextRef {

166 let ctx = JSContextRef {

167+ contextId = contextId'

162− startTime = startTime'

168+ , startTime = startTime'

163 , doSendCommand = \cmd -> cmd `deepseq` do

169 , doSendCommand = \cmd -> cmd `deepseq` do

164 result <- newEmptyMVar

170 result <- newEmptyMVar

165 atomically $ writeTChan commandChan (Right (cmd, result))

171 atomically $ writeTChan commandChan (Right (cmd, result))

@@ -172,13 +178,14 @@ runJavaScript sendBatch entryPoint = do

172 , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)

178 , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)

173 , nextRef = nextRef'

179 , nextRef = nextRef'

174 , doEnableLogging = atomicWriteIORef loggingEnabled

180 , doEnableLogging = atomicWriteIORef loggingEnabled

181+ , finalizerThreads = finalizerThreads'

175 }

182 }

176 let processResults :: Bool -> Results -> IO ()

183 let processResults :: Bool -> Results -> IO ()

177 processResults syncCallbacks = \case

184 processResults syncCallbacks = \case

178 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

185 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

179− (Callback n br f this a) -> do

186+ (Callback n br (JSValueReceived fNumber) f this a) -> do

180 putMVar recvMVar (n, br)

187 putMVar recvMVar (n, br)

181− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx

188+ f' <- runReaderT (unJSM $ wrapJSVal f) ctx

182 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

189 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

183 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

190 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

184 logInfo (("Call " <> show fNumber <> " ") <>)

191 logInfo (("Call " <> show fNumber <> " ") <>)

@@ -207,7 +214,7 @@ runJavaScript sendBatch entryPoint = do

207 True -> show . currentBytesUsed <$> getGCStats

214 True -> show . currentBytesUsed <$> getGCStats

208 False -> return "??"

215 False -> return "??"

209 cbCount <- M.size <$> readTVarIO callbacks

216 cbCount <- M.size <$> readTVarIO callbacks

210− putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount

217+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "

211 False -> return ()

218 False -> return ()

212 _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->

219 _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->

213 readBatch nBatch commandChan >>= \case

220 readBatch nBatch commandChan >>= \case

@@ -229,7 +236,7 @@ runJavaScript sendBatch entryPoint = do

229 where

236 where

230 numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()

237 numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()

231 numberForeverFromM_ !n f = do

238 numberForeverFromM_ !n f = do

232− f n

239+ _ <- f n

233 numberForeverFromM_ (succ n) f

240 numberForeverFromM_ (succ n) f

234 takeResult recvMVar nBatch =

241 takeResult recvMVar nBatch =

235 takeMVar recvMVar >>= \case

242 takeMVar recvMVar >>= \case

@@ -263,12 +270,27 @@ runJavaScript sendBatch entryPoint = do

263 loopAnimation (Left asyncCmd) (cmds, resultMVars) =

270 loopAnimation (Left asyncCmd) (cmds, resultMVars) =

264 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)

271 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)

265

272

273+addThreadFinalizer :: ThreadId -> IO () -> IO ()

274+addThreadFinalizer t@(ThreadId t#) (IO finalizer) =

275+ IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }

276+

266wrapJSVal :: JSValueReceived -> JSM JSVal

277wrapJSVal :: JSValueReceived -> JSM JSVal

267wrapJSVal (JSValueReceived ref) = do

278wrapJSVal (JSValueReceived ref) = do

268 -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)

279 -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)

269 let result = JSVal ref

280 let result = JSVal ref

270− when (ref >= 5) $ do

281+ when (ref >= 5 || ref < 0) $ do

271 ctx <- JSM ask

282 ctx <- JSM ask

283+ liftIO . addFinalizer ref $ do

284+ ft <- takeMVar $ finalizerThreads ctx

285+ t <- myThreadId

286+ let tname = T.pack $ show t

272− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref

287+ doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend ref

288+ if tname `S.member` ft

289+ then putMVar (finalizerThreads ctx) ft

290+ else do

291+ addThreadFinalizer t $ do

292+ modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())

293+ doSendAsyncCommand ctx $ FreeRefs tname

294+ putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)

273 return result

295 return result

274#endif

296#endif

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+27−10

@@ -37,6 +37,7 @@ indexHtml =

37initState :: ByteString

38initState = "\

39 \ var jsaddle_values = new Map();\n\

40+ \ var jsaddle_free = new Map();\n\

40 \ jsaddle_values.set(0, null);\n\

41 \ jsaddle_values.set(0, null);\n\

41 \ jsaddle_values.set(1, undefined);\n\

42 \ jsaddle_values.set(1, undefined);\n\

42 \ jsaddle_values.set(2, false);\n\

43 \ jsaddle_values.set(2, false);\n\

@@ -67,7 +68,15 @@ runBatch send sendSync = "\

67 \ var d = cmd.Left;\n\

68 \ var d = cmd.Left;\n\

68 \ switch (d.tag) {\n\

69 \ switch (d.tag) {\n\

69 \ case \"FreeRef\":\n\

70 \ case \"FreeRef\":\n\

71+ \ var refsToFree = jsaddle_free.get(d.contents[0]) || [];\n\

72+ \ refsToFree.push(d.contents[1]);\n\

73+ \ jsaddle_free.set(d.contents[0], refsToFree);\n\

74+ \ break;\n\

75+ \ case \"FreeRefs\":\n\

76+ \ var refsToFree = jsaddle_free.get(d.contents) || [];\n\

77+ \ for(var nRef = 0; nRef != refsToFree.length; nRef++)\n\

70− \ jsaddle_values.delete(d.contents);\n\

78+ \ jsaddle_values.delete(refsToFree[nRef]);\n\

79+ \ jsaddle_free.delete(d.contents);\n\

71 \ break;\n\

80 \ break;\n\

72 \ case \"SetPropertyByName\":\n\

81 \ case \"SetPropertyByName\":\n\

73 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\

82 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\

@@ -102,7 +111,9 @@ runBatch send sendSync = "\

102 \ case \"NewAsyncCallback\":\n\

111 \ case \"NewAsyncCallback\":\n\

103 \ (function() {\n\

112 \ (function() {\n\

104 \ var nFunction = d.contents;\n\

113 \ var nFunction = d.contents;\n\

114+ \ var func = function() {\n\

115+ \ var nFunctionInFunc = ++jsaddle_index;\n\

105− \ jsaddle_values.set(nFunction, function() {\n\

116+ \ jsaddle_values.set(nFunctionInFunc, func);\n\

106 \ var nThis = ++jsaddle_index;\n\

117 \ var nThis = ++jsaddle_index;\n\

107 \ jsaddle_values.set(nThis, this);\n\

118 \ jsaddle_values.set(nThis, this);\n\

108 \ var args = [];\n\

119 \ var args = [];\n\

@@ -111,13 +122,17 @@ runBatch send sendSync = "\

111 \ jsaddle_values.set(nArg, arguments[i]);\n\

122 \ jsaddle_values.set(nArg, arguments[i]);\n\

112 \ args[i] = nArg;\n\

123 \ args[i] = nArg;\n\

113 \ }\n\

124 \ }\n\

114− \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\

125+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\

126+ \ };\n\

127+ \ jsaddle_values.set(nFunction, func);\n\

115− \ })})();\n\

128+ \ })();\n\

116 \ break;\n\

129 \ break;\n\

117 \ case \"NewSyncCallback\":\n\

130 \ case \"NewSyncCallback\":\n\

118 \ (function() {\n\

131 \ (function() {\n\

119 \ var nFunction = d.contents;\n\

132 \ var nFunction = d.contents;\n\

133+ \ var func = function() {\n\

134+ \ var nFunctionInFunc = ++jsaddle_index;\n\

120− \ jsaddle_values.set(nFunction, function() {\n\

135+ \ jsaddle_values.set(nFunctionInFunc, func);\n\

121 \ var nThis = ++jsaddle_index;\n\

136 \ var nThis = ++jsaddle_index;\n\

122 \ jsaddle_values.set(nThis, this);\n\

137 \ jsaddle_values.set(nThis, this);\n\

123 \ var args = [];\n\

138 \ var args = [];\n\

@@ -129,14 +144,16 @@ runBatch send sendSync = "\

129 case sendSync of

144 case sendSync of

130 Just s ->

145 Just s ->

131 " if(inCallback > 0) {\n\

146 " if(inCallback > 0) {\n\

132− \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\

147+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\

133 \ } else {\n\

148 \ } else {\n\

134− \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> ", 1);\n\

149+ \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> ", 1);\n\

135 \ }\n"

150 \ }\n"

136 Nothing ->

151 Nothing ->

137− " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n"

152+ " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n"

138 ) <>

153 ) <>

154+ " };\n\

155+ \ jsaddle_values.set(nFunction, func);\n\

139− " })})();\n\

156+ \ })();\n\

140 \ break;\n\

157 \ break;\n\

141 \ case \"CallAsFunction\":\n\

158 \ case \"CallAsFunction\":\n\

142 \ var n = d.contents[3];\n\

159 \ var n = d.contents[3];\n\

@@ -179,7 +196,7 @@ runBatch send sendSync = "\

179 \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\

196 \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\

180 \ break;\n\

197 \ break;\n\

181 \ case \"SyncWithAnimationFrame\":\n\

198 \ case \"SyncWithAnimationFrame\":\n\

182− \ var n = d.contents[0];\n\

199+ \ var n = d.contents;\n\

183 \ jsaddle_values.set(n, timestamp);\n\

200 \ jsaddle_values.set(n, timestamp);\n\

184 \ break;\n\

201 \ break;\n\

185 \ case \"StartSyncBlock\":\n\

202 \ case \"StartSyncBlock\":\n\

jsaddle/src/Language/Javascript/JSaddle/Types.hs+60−16

@@ -106,7 +106,10 @@ import Control.Monad.Trans.Class (MonadTrans(..))

106import Control.Monad.Fix (MonadFix)

107import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

108import Control.Concurrent.STM.TVar (TVar)

109+import Control.Concurrent.MVar (MVar)

110+import Data.Set (Set)

109import Data.Text (Text)

111import Data.Text (Text)

112+import Data.UUID (UUID)

110import Data.Time.Clock (UTCTime(..))

113import Data.Time.Clock (UTCTime(..))

111import Data.Typeable (Typeable)

114import Data.Typeable (Typeable)

112import Data.Coerce (coerce, Coercible)

115import Data.Coerce (coerce, Coercible)

@@ -129,13 +132,15 @@ import GHC.Exts (Constraint)

129type JSContextRef = ()

132type JSContextRef = ()

130#else

133#else

131data JSContextRef = JSContextRef {

134data JSContextRef = JSContextRef {

135+ contextId :: UUID

132− startTime :: UTCTime

136+ , startTime :: UTCTime

133 , doSendCommand :: Command -> IO Result

137 , doSendCommand :: Command -> IO Result

134 , doSendAsyncCommand :: AsyncCommand -> IO ()

138 , doSendAsyncCommand :: AsyncCommand -> IO ()

135 , addCallback :: Object -> JSCallAsFunction -> IO ()

139 , addCallback :: Object -> JSCallAsFunction -> IO ()

136 , freeCallback :: Object -> IO ()

140 , freeCallback :: Object -> IO ()

137 , nextRef :: TVar JSValueRef

141 , nextRef :: TVar JSValueRef

138 , doEnableLogging :: Bool -> IO ()

142 , doEnableLogging :: Bool -> IO ()

143+ , finalizerThreads :: MVar (Set Text)

139}

144}

140#endif

145#endif

141

146

@@ -211,19 +216,57 @@ instance MonadJSM JSM where

211 liftJSM' = id

216 liftJSM' = id

212 {-# INLINE liftJSM' #-}

217 {-# INLINE liftJSM' #-}

213

218

214−instance (MonadJSM m) => MonadJSM (ContT r m)

219+instance (MonadJSM m) => MonadJSM (ContT r m) where

220+ liftJSM' = lift . liftJSM'

221+ {-# INLINE liftJSM' #-}

222+

215−instance (Error e, MonadJSM m) => MonadJSM (ErrorT e m)

223+instance (Error e, MonadJSM m) => MonadJSM (ErrorT e m) where

224+ liftJSM' = lift . liftJSM'

225+ {-# INLINE liftJSM' #-}

226+

216−instance (MonadJSM m) => MonadJSM (ExceptT e m)

227+instance (MonadJSM m) => MonadJSM (ExceptT e m) where

228+ liftJSM' = lift . liftJSM'

229+ {-# INLINE liftJSM' #-}

230+

217−instance (MonadJSM m) => MonadJSM (IdentityT m)

231+instance (MonadJSM m) => MonadJSM (IdentityT m) where

232+ liftJSM' = lift . liftJSM'

233+ {-# INLINE liftJSM' #-}

234+

218−instance (MonadJSM m) => MonadJSM (ListT m)

235+instance (MonadJSM m) => MonadJSM (ListT m) where

236+ liftJSM' = lift . liftJSM'

237+ {-# INLINE liftJSM' #-}

238+

219−instance (MonadJSM m) => MonadJSM (MaybeT m)

239+instance (MonadJSM m) => MonadJSM (MaybeT m) where

240+ liftJSM' = lift . liftJSM'

241+ {-# INLINE liftJSM' #-}

242+

220−instance (MonadJSM m) => MonadJSM (ReaderT r m)

243+instance (MonadJSM m) => MonadJSM (ReaderT r m) where

244+ liftJSM' = lift . liftJSM'

245+ {-# INLINE liftJSM' #-}

246+

221−instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.RWST r w s m)

247+instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.RWST r w s m) where

248+ liftJSM' = lift . liftJSM'

249+ {-# INLINE liftJSM' #-}

250+

222−instance (Monoid w, MonadJSM m) => MonadJSM (Strict.RWST r w s m)

251+instance (Monoid w, MonadJSM m) => MonadJSM (Strict.RWST r w s m) where

252+ liftJSM' = lift . liftJSM'

253+ {-# INLINE liftJSM' #-}

254+

223−instance (MonadJSM m) => MonadJSM (Lazy.StateT s m)

255+instance (MonadJSM m) => MonadJSM (Lazy.StateT s m) where

256+ liftJSM' = lift . liftJSM'

257+ {-# INLINE liftJSM' #-}

258+

224−instance (MonadJSM m) => MonadJSM (Strict.StateT s m)

259+instance (MonadJSM m) => MonadJSM (Strict.StateT s m) where

260+ liftJSM' = lift . liftJSM'

261+ {-# INLINE liftJSM' #-}

262+

225−instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m)

263+instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m) where

264+ liftJSM' = lift . liftJSM'

265+ {-# INLINE liftJSM' #-}

266+

226−instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m)

267+instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m) where

268+ liftJSM' = lift . liftJSM'

269+ {-# INLINE liftJSM' #-}

227

270

228instance MonadRef JSM where

271instance MonadRef JSM where

229 type Ref JSM = Ref IO

272 type Ref JSM = Ref IO

@@ -320,7 +363,8 @@ newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON,

320instance NFData JSStringForSend

363instance NFData JSStringForSend

321

364

322-- | Command sent to a JavaScript context for execution asynchronously

365-- | Command sent to a JavaScript context for execution asynchronously

323−data AsyncCommand = FreeRef JSValueForSend

366+data AsyncCommand = FreeRef Text JSValueForSend

367+ | FreeRefs Text

324 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

368 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

325 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend

369 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend

326 | StringToValue JSStringForSend JSValueForSend

370 | StringToValue JSStringForSend JSValueForSend

@@ -412,7 +456,7 @@ instance FromJSON BatchResults

412

456

413data Results = BatchResults Int BatchResults

457data Results = BatchResults Int BatchResults

414 | Duplicate Int Int

458 | Duplicate Int Int

415− | Callback Int BatchResults JSValueReceived JSValueReceived [JSValueReceived]

459+ | Callback Int BatchResults JSValueReceived JSValueReceived JSValueReceived [JSValueReceived]

416 | ProtocolError Text

460 | ProtocolError Text

417 deriving (Show, Generic)

461 deriving (Show, Generic)

418

462