cd61e54 · jsaddle · git.iko.soy

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

compare with master

unifiedsplit

@@ -4,8 +4,21 @@

4typedef struct native_callbacks {

5 void (* jsaddleStart) ();

6 void (* jsaddleResult) (char *);

7+ char * (* jsaddleSyncResult) (char *);

7 char * jsaddleJsData;

8 char * jsaddleJsData;

8 char * jsaddleHtmlData;

9 char * jsaddleHtmlData;

9} native_callbacks;

10} native_callbacks;

10

11

12+typedef struct app_callbacks {

13+ void (* mainActivity_onCreate) ();

14+ void (* mainActivity_onStart) ();

15+ void (* mainActivity_onResume) ();

16+ void (* mainActivity_onPause) ();

17+ void (* mainActivity_onStop) ();

18+ void (* mainActivity_onDestroy) ();

19+ void (* mainActivity_onRestart) ();

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

21+ void (* firebaseInstanceIdService_sendRegistrationToServer) (char *);

22+} app_callbacks;

23+

11#endif

24#endif

jsaddle-clib/default.nix+3−3

@@ -1,9 +1,9 @@

1−{ mkDerivation, aeson, base, bytestring, jsaddle, stdenv }:

1+{ mkDerivation, aeson, base, bytestring, data-default, jsaddle, stdenv, text }:

2mkDerivation {

3 pname = "jsaddle-clib";

4− version = "0.8.2.0";

4+ version = "0.9.0.0";

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

6− libraryHaskellDepends = [ aeson base bytestring jsaddle ];

6+ libraryHaskellDepends = [ aeson base bytestring data-default jsaddle text ];

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

8 license = stdenv.lib.licenses.mit;

9}

jsaddle-clib/jsaddle-clib.cabal+4−2

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

1name: jsaddle-clib

2−version: 0.8.3.0

2+version: 0.9.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -24,7 +24,9 @@ library

24 aeson >=0.8.0.2 && <1.3,

25 base <5,

26 bytestring >=0.10.6.0 && <0.11,

27− jsaddle >= 0.8.0.0 && <0.9

27+ jsaddle >= 0.9.0.0 && <0.10,

28+ data-default,

29+ text

28 default-language: Haskell2010

30 default-language: Haskell2010

29 hs-source-dirs: src

31 hs-source-dirs: src

30 Include-dirs: cbits/include

32 Include-dirs: cbits/include

jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hs+88−8

@@ -2,19 +2,27 @@

2module Language.Javascript.JSaddle.CLib

3 ( jsaddleInit

4 , NativeCallbacks (..)

5+ , AppCallbacks (..)

6+ , AppConfig (..)

7+ , pokeAppConfig

8+ , appConfigToAppCallbacks

5 ) where

9 ) where

6

10

7import Control.Monad (void)

11import Control.Monad (void)

8import Control.Concurrent (forkIO)

12import Control.Concurrent (forkIO)

9

13

10−import Data.Monoid ((<>))

14+import Data.Aeson (encode, decode)

11import Data.ByteString (useAsCString, packCString)

15import Data.ByteString (useAsCString, packCString)

12−import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)

13import Data.ByteString.Char8 (unpack)

16import Data.ByteString.Char8 (unpack)

14−import Data.Aeson (encode, decode)

17+import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)

18+import Data.Default (def, Default)

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

20+import Data.Text (Text)

21+import qualified Data.Text.Encoding as T

15

22

16import Foreign.C.String (CString, newCString)

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

17import Foreign.Ptr (FunPtr, Ptr)

24import Foreign.Ptr (FunPtr, Ptr)

25+import Foreign.Storable (poke)

18import Foreign.Marshal.Utils (new)

26import Foreign.Marshal.Utils (new)

19

27

20import Language.Javascript.JSaddle (JSM)

28import Language.Javascript.JSaddle (JSM)

@@ -32,33 +40,105 @@ foreign import ccall safe "wrapper"

32foreign import ccall safe "wrapper"

40foreign import ccall safe "wrapper"

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

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

34

42

43+foreign import ccall safe "wrapper"

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

45+

46+foreign import ccall safe "wrapper"

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

48+

35jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks)

49jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks)

36jsaddleInit jsm evaluateJavascriptAsyncPtr = do

50jsaddleInit jsm evaluateJavascriptAsyncPtr = do

37 let evaluateJavascriptAsync = mkCallback evaluateJavascriptAsyncPtr

51 let evaluateJavascriptAsync = mkCallback evaluateJavascriptAsyncPtr

38− (processResult, _, start) <- runJavaScript (\batch ->

52+ (processResult, processSyncResult, start) <- runJavaScript (\batch ->

39− useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $

53+ useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");")

40 evaluateJavascriptAsync) jsm

54 evaluateJavascriptAsync) jsm

41− jsaddleStartPtr <- wrapStartCallback $ void $ forkIO $ start

55+ jsaddleStartPtr <- wrapStartCallback $ void $ forkIO start

42 jsaddleResultPtr <- wrapMessageCallback $ \s -> do

56 jsaddleResultPtr <- wrapMessageCallback $ \s -> do

43 result <- decode . fromStrict <$> packCString s

57 result <- decode . fromStrict <$> packCString s

44 case result of

58 case result of

45 Nothing -> error $ "jsaddle message decode failed: " <> show result

59 Nothing -> error $ "jsaddle message decode failed: " <> show result

46 Just r -> processResult r

60 Just r -> processResult r

61+ jsaddleSyncResultPtr <- wrapSyncCallback $ \s -> do

62+ result <- decode . fromStrict <$> packCString s

63+ case result of

64+ Nothing -> error $ "jsaddle message decode failed: " <> show result

65+ Just r -> newCString =<< unpack . toStrict . encode <$> processSyncResult r

47 jsaddleJsPtr <- newCString $ unpack $ toStrict jsaddleJs

66 jsaddleJsPtr <- newCString $ unpack $ toStrict jsaddleJs

48 jsaddleHtmlPtr <- newCString $ unpack $ toStrict indexHtml

67 jsaddleHtmlPtr <- newCString $ unpack $ toStrict indexHtml

49− new $ NativeCallbacks

68+ new NativeCallbacks

50 { _nativeCallbacks_jsaddleStart = jsaddleStartPtr

69 { _nativeCallbacks_jsaddleStart = jsaddleStartPtr

51 , _nativeCallbacks_jsaddleResult = jsaddleResultPtr

70 , _nativeCallbacks_jsaddleResult = jsaddleResultPtr

71+ , _nativeCallbacks_jsaddleSyncResult = jsaddleSyncResultPtr

52 , _nativeCallbacks_jsaddleJsData = jsaddleJsPtr

72 , _nativeCallbacks_jsaddleJsData = jsaddleJsPtr

53 , _nativeCallbacks_jsaddleHtmlData = jsaddleHtmlPtr

73 , _nativeCallbacks_jsaddleHtmlData = jsaddleHtmlPtr

54 }

74 }

55

75

76+data AppConfig = AppConfig

77+ { _appConfig_mainActivityOnCreate :: IO ()

78+ , _appConfig_mainActivityOnStart :: IO ()

79+ , _appConfig_mainActivityOnResume :: IO ()

80+ , _appConfig_mainActivityOnPause :: IO ()

81+ , _appConfig_mainActivityOnStop :: IO ()

82+ , _appConfig_mainActivityOnDestroy :: IO ()

83+ , _appConfig_mainActivityOnRestart :: IO ()

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

85+ , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO ()

86+ }

87+

88+instance Default AppConfig where

89+ def = AppConfig

90+ { _appConfig_mainActivityOnCreate = return ()

91+ , _appConfig_mainActivityOnStart = return ()

92+ , _appConfig_mainActivityOnResume = return ()

93+ , _appConfig_mainActivityOnPause = return ()

94+ , _appConfig_mainActivityOnStop = return ()

95+ , _appConfig_mainActivityOnDestroy = return ()

96+ , _appConfig_mainActivityOnRestart = return ()

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

98+ , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer = \_ -> return ()

99+ }

100+

101+appConfigToAppCallbacks :: AppConfig -> IO AppCallbacks

102+appConfigToAppCallbacks c = do

103+ create <- wrapStartCallback $ _appConfig_mainActivityOnCreate c

104+ start <- wrapStartCallback $ _appConfig_mainActivityOnStart c

105+ resume <- wrapStartCallback $ _appConfig_mainActivityOnResume c

106+ pause <- wrapStartCallback $ _appConfig_mainActivityOnPause c

107+ stop <- wrapStartCallback $ _appConfig_mainActivityOnStop c

108+ destroy <- wrapStartCallback $ _appConfig_mainActivityOnDestroy 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'

114+ firebaseRegPtr <- wrapMessageCallback $ \token -> do

115+ token' <- fromUtf8CString token

116+ _appConfig_firebaseInstanceIdServiceSendRegistrationToServer c token'

117+ return $ AppCallbacks

118+ { _appCallbacks_mainActivity_onCreate = create

119+ , _appCallbacks_mainActivity_onStart = start

120+ , _appCallbacks_mainActivity_onResume = resume

121+ , _appCallbacks_mainActivity_onPause = pause

122+ , _appCallbacks_mainActivity_onStop = stop

123+ , _appCallbacks_mainActivity_onDestroy = destroy

124+ , _appCallbacks_mainActivity_onRestart = restart

125+ , _appCallbacks_mainActivity_onNewIntent = newIntent

126+ , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer = firebaseRegPtr

127+ }

128+

129+fromUtf8CString :: CString -> IO Text

130+fromUtf8CString = fmap T.decodeUtf8 . packCString

131+

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

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

134+

56jsaddleJs :: ByteString

135jsaddleJs :: ByteString

57jsaddleJs = ghcjsHelpers <> "\

136jsaddleJs = ghcjsHelpers <> "\

58 \runJSaddleBatch = (function() {\n\

137 \runJSaddleBatch = (function() {\n\

59 \ " <> initState <> "\n\

138 \ " <> initState <> "\n\

60 \ return function(batch) {\n\

139 \ return function(batch) {\n\

61− \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));") Nothing <> "\

140+ \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));")

141+ (Just (\a -> "JSON.parse(jsaddle.syncMessage(JSON.stringify(" <> a <> ")))")) <> "\

62 \ };\n\

142 \ };\n\

63 \})();\n\

143 \})();\n\

64 \jsaddle.postReady();\n"

144 \jsaddle.postReady();\n"

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

@@ -9,6 +9,7 @@ import Foreign.C

9data NativeCallbacks = NativeCallbacks

10 { _nativeCallbacks_jsaddleStart :: !(FunPtr (IO ())) -- void (jsaddleStart *)()

11 , _nativeCallbacks_jsaddleResult :: !(FunPtr (CString -> IO ())) -- void (jsaddleResult *)(char *)

12+ , _nativeCallbacks_jsaddleSyncResult :: !(FunPtr (CString -> IO CString)) -- char * (jsaddleSyncResult *)(char *)

12 , _nativeCallbacks_jsaddleJsData :: !CString -- char * jsaddleJsData

13 , _nativeCallbacks_jsaddleJsData :: !CString -- char * jsaddleJsData

13 , _nativeCallbacks_jsaddleHtmlData :: !CString -- char * jsaddleHtmlData

14 , _nativeCallbacks_jsaddleHtmlData :: !CString -- char * jsaddleHtmlData

14 }

15 }

@@ -19,10 +20,48 @@ instance Storable NativeCallbacks where

19 poke p nc = do

20 poke p nc = do

20 #{poke native_callbacks, jsaddleStart} p $ _nativeCallbacks_jsaddleStart nc

21 #{poke native_callbacks, jsaddleStart} p $ _nativeCallbacks_jsaddleStart nc

21 #{poke native_callbacks, jsaddleResult} p $ _nativeCallbacks_jsaddleResult nc

22 #{poke native_callbacks, jsaddleResult} p $ _nativeCallbacks_jsaddleResult nc

23+ #{poke native_callbacks, jsaddleSyncResult} p $ _nativeCallbacks_jsaddleSyncResult nc

22 #{poke native_callbacks, jsaddleJsData} p $ _nativeCallbacks_jsaddleJsData nc

24 #{poke native_callbacks, jsaddleJsData} p $ _nativeCallbacks_jsaddleJsData nc

23 #{poke native_callbacks, jsaddleHtmlData} p $ _nativeCallbacks_jsaddleHtmlData nc

25 #{poke native_callbacks, jsaddleHtmlData} p $ _nativeCallbacks_jsaddleHtmlData nc

24 peek p = NativeCallbacks

26 peek p = NativeCallbacks

25 <$> #{peek native_callbacks, jsaddleStart} p

27 <$> #{peek native_callbacks, jsaddleStart} p

26 <*> #{peek native_callbacks, jsaddleResult} p

28 <*> #{peek native_callbacks, jsaddleResult} p

29+ <*> #{peek native_callbacks, jsaddleSyncResult} p

27 <*> #{peek native_callbacks, jsaddleJsData} p

30 <*> #{peek native_callbacks, jsaddleJsData} p

28 <*> #{peek native_callbacks, jsaddleHtmlData} p

31 <*> #{peek native_callbacks, jsaddleHtmlData} p

32+

33+data AppCallbacks = AppCallbacks

34+ { _appCallbacks_mainActivity_onCreate :: !(FunPtr (IO ()))

35+ , _appCallbacks_mainActivity_onStart :: !(FunPtr (IO ()))

36+ , _appCallbacks_mainActivity_onResume :: !(FunPtr (IO ()))

37+ , _appCallbacks_mainActivity_onPause :: !(FunPtr (IO ()))

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 ()))

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

43+ }

44+

45+instance Storable AppCallbacks where

46+ sizeOf _ = #{size app_callbacks}

47+ alignment _ = #{alignment app_callbacks}

48+ poke p nc = do

49+ #{poke app_callbacks, mainActivity_onCreate} p $ _appCallbacks_mainActivity_onCreate nc

50+ #{poke app_callbacks, mainActivity_onStart} p $ _appCallbacks_mainActivity_onStart nc

51+ #{poke app_callbacks, mainActivity_onResume} p $ _appCallbacks_mainActivity_onResume nc

52+ #{poke app_callbacks, mainActivity_onPause} p $ _appCallbacks_mainActivity_onPause nc

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

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

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

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

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

58+ peek p = AppCallbacks

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

60+ <*> #{peek app_callbacks, mainActivity_onStart} p

61+ <*> #{peek app_callbacks, mainActivity_onResume} p

62+ <*> #{peek app_callbacks, mainActivity_onPause} p

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

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

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

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

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

jsaddle-warp/default.nix+12−14

@@ -1,24 +1,22 @@

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

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

2+, doctest, filepath, ghc-prim, http-types, jsaddle, lens, network

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

3+, primitive, process, QuickCheck, ref-tf, stdenv, stm, text, time

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

4+, transformers, uuid, uuid-types, wai, wai-websockets, warp

5−, darwin, webdriver, phantomjs, ghc

5+, webdriver, websockets

6}:

7mkDerivation {

8 pname = "jsaddle-warp";

9− version = "0.8.2.0";

9+ version = "0.9.1.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 http-types jsaddle stm text time

13− wai wai-websockets warp websockets

13+ transformers uuid uuid-types wai wai-websockets warp websockets

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

15− ] else if stdenv.isDarwin then [

16−# osx_sdk darwin.libobjc darwin.apple_sdk.libs.xpc

17− ] else [

18− ]);

14+ ];

19 testHaskellDepends = [

15 testHaskellDepends = [

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

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

21− primitive process QuickCheck ref-tf webdriver phantomjs

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

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

19+ websockets

22 ];

20 ];

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

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

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

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

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

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

1name: jsaddle-warp

2−version: 0.8.3.1

2+version: 0.9.1.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -26,13 +26,16 @@ 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,

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

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

31− jsaddle >=0.8.0.0 && <0.9,

32+ jsaddle >=0.9.0.0 && <0.10,

32 stm >=2.4.4 && <2.5,

33 stm >=2.4.4 && <2.5,

33 text >=1.2.1.3 && <1.3,

34 text >=1.2.1.3 && <1.3,

34 time >=1.5.0.1 && <1.8,

35 time >=1.5.0.1 && <1.8,

35 transformers >=0.4.2.0 && <0.6,

36 transformers >=0.4.2.0 && <0.6,

37+ uuid >=1.3.13 && <1.4,

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

36 wai >=3.0.3.0 && <3.3,

39 wai >=3.0.3.0 && <3.3,

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

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

38 warp >=3.1.2 && <3.3,

41 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

24

23

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

29

28

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

34

33

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+122−44

@@ -16,6 +16,8 @@ module Language.Javascript.JSaddle.WebSockets (

16 -- * Running JSM over WebSockets

17 jsaddleOr

18 , jsaddleApp

19+ , jsaddleWithAppOr

20+ , jsaddleAppPartial

19) where

21) where

20

22

21import Control.Monad (forever)

23import Control.Monad (forever)

@@ -25,7 +27,8 @@ import Control.Exception (handle, AsyncException, throwIO, fromException)

25import Data.Monoid ((<>))

27import Data.Monoid ((<>))

26import Data.Aeson (encode, decode)

28import Data.Aeson (encode, decode)

27

29

28−import Network.Wai (Application)

30+import Network.Wai

31+ (lazyRequestBody, Application, Request, Response, ResponseReceived)

29import Network.WebSockets

32import Network.WebSockets

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

33 (ConnectionOptions(..), sendTextData, receiveDataMessage,

31 acceptRequest, ServerApp, sendPing)

34 acceptRequest, ServerApp, sendPing)

@@ -34,55 +37,130 @@ import Network.Wai.Handler.WebSockets (websocketsOr)

34

37

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

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

36import qualified Network.Wai as W

39import qualified Network.Wai as W

37− (responseLBS, requestMethod, Application, pathInfo)

40+ (responseLBS, requestMethod, pathInfo)

38−import Data.Text (Text)

39import qualified Data.Text as T (pack)

41import qualified Data.Text as T (pack)

40import qualified Network.HTTP.Types as H

42import qualified Network.HTTP.Types as H

41− (status403, status200, status405)

43+ (status403, status200)

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

44import Language.Javascript.JSaddle.Run (runJavaScript)

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

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

46+import Data.Maybe (fromMaybe)

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

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

49+import Data.ByteString.Lazy (fromStrict, ByteString)

50+import Data.Text (Text)

51+import Data.UUID.Types (toText)

52+import Data.UUID.V4 (nextRandom)

53+

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

55+jsaddleOr opts entryPoint otherApp = do

56+ syncHandlers <- newIORef M.empty

57+ let wsApp :: ServerApp

58+ wsApp pending_conn = do

59+ conn <- acceptRequest pending_conn

60+ (processResult, processSyncResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint

61+ _ <- forkIO . forever $

62+ receiveDataMessage conn >>= \case

63+ (WS.Text t) ->

64+ case decode t of

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

66+ Just r -> processResult r

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

68+ syncKey <- toText <$> nextRandom

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

70+ sendTextData conn (encode syncKey)

71+ start

72+ waitTillClosed conn

73+

74+ -- Based on Network.WebSocket.forkPingThread

75+ waitTillClosed conn = ignore `handle` go 1

76+ where

77+ go :: Int -> IO ()

78+ go i = do

79+ threadDelay (1 * 1000 * 1000)

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

81+ go (i + 1)

44

82

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

83+ ignore e = case fromException e of

46−jsaddleOr opts entryPoint = websocketsOr opts wsApp

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

47− where

85+ Nothing -> return ()

48− wsApp :: ServerApp

49− wsApp pending_conn = do

50− conn <- acceptRequest pending_conn

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

52− _ <- forkIO . forever $

53− receiveDataMessage conn >>= \case

54− (WS.Text t) ->

55− case decode t of

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

57− Just r -> processResult r

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

59− start

60− waitTillClosed conn

61

86

62− -- Based on Network.WebSocket.forkPingThread

87+ syncHandler :: Application

63− waitTillClosed conn = ignore `handle` go 1

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

64− where

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

65− go :: Int -> IO ()

90+ body <- lazyRequestBody req

66− go i = do

91+ case decode body of

67− threadDelay (1 * 1000 * 1000)

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

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

93+ Just result ->

69− go (i + 1)

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

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

96+ Just handler -> do

97+ next <- encode <$> handler result

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

99+ _ -> otherApp req sendResponse

100+ return $ websocketsOr opts wsApp syncHandler

70

101

71− ignore e = case fromException e of

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

73− Nothing -> return ()

74

102

75jsaddleApp :: Application

103jsaddleApp :: Application

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

104+jsaddleApp req sendResponse =

105+ fromMaybe

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

107+ (jsaddleAppPartial req sendResponse)

108+

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

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

111+ (fromMaybe (otherApp req sendResponse)

112+ (jsaddleAppPartial req sendResponse))

113+

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

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

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

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

118+ _ -> Nothing

119+

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

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

122+jsaddleJs :: ByteString

123+jsaddleJs = "\

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

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

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

127+ \}\n\

128+ \\n\

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

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

131+ \\n\

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

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

134+ \\n\

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

136+ \ " <> initState <> "\n\

137+ \ var inXhrSend = false;\n\

138+ \\n\

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

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

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

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

143+ \ syncKey = batch;\n\

144+ \ return;\n\

145+ \ }\n\

146+ \\n\

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

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

149+ \ inXhrSend = true;\n\

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

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

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

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

154+ \ inXhrSend = false;\n\

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

156+ \ };\n\

157+ \ };\n\

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

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

160+ \ };\n\

161+ \}\n\

162+ \\n\

163+ \ " <> ghcjsHelpers <> "\

164+ \connect();\n\

165+ \"

77

166

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

79−jsaddleAppPieces _ req sendResponse

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

81− H.status405

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

83− "Only GET or HEAD is supported"

84−jsaddleAppPieces [] _req sendResponse = 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

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

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

88− ] "Forbidden"

jsaddle-webkit2gtk/default.nix+1−1

@@ -4,7 +4,7 @@

4}:

5mkDerivation {

6 pname = "jsaddle-webkit2gtk";

7− version = "0.8.2.2";

7+ version = "0.9.0.0";

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

9 libraryHaskellDepends = [

10 aeson base bytestring directory gi-gio gi-glib gi-gtk

jsaddle-webkit2gtk/jsaddle-webkit2gtk.cabal+2−2

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

1name: jsaddle-webkit2gtk

2−version: 0.8.3.1

2+version: 0.9.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -36,7 +36,7 @@ library

36 gi-webkit2 >=4.0.6 && <4.1,

37 gi-javascriptcore >=4.0.6 && <4.1,

38 haskell-gi-base >=0.20 && <0.21,

39− jsaddle >=0.8.0.0 && <0.9,

39+ jsaddle >=0.9.0.0 && <0.10,

40 text >=1.2.1.3 && <1.3,

41 webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15

42 if !os(windows)

jsaddle-webkitgtk/default.nix+1−1

@@ -4,7 +4,7 @@

4}:

5mkDerivation {

6 pname = "jsaddle-webkitgtk";

7− version = "0.8.2.2";

7+ version = "0.9.0.0";

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

9 libraryHaskellDepends = [

10 aeson base bytestring directory gi-glib gi-gtk gi-javascriptcore

jsaddle-webkitgtk/jsaddle-webkitgtk.cabal+2−2

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

1name: jsaddle-webkitgtk

2−version: 0.8.3.1

2+version: 0.9.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -32,7 +32,7 @@ library

32 gi-webkit >=3.0.6 && <3.1,

33 gi-javascriptcore >=3.0.6 && <3.1,

34 haskell-gi-base >=0.20 && <0.21,

35− jsaddle >=0.8.0.0 && <0.9,

35+ jsaddle >=0.9.0.0 && <0.10,

36 text >=1.2.1.3 && <1.3,

37 webkitgtk3-javascriptcore >=0.14.0.0 && <0.15

38 if !os(windows)

jsaddle-wkwebview/cbits-cocoa/AppDelegate.m+2−2

@@ -2,7 +2,7 @@

2#import <Cocoa/Cocoa.h>

3#import <WebKit/WebKit.h>

4

5−extern void withWebView(WKWebView *, HsStablePtr);

5+extern void callWithWebView(WKWebView *, HsStablePtr);

6

7@interface AppDelegate : NSObject <NSApplicationDelegate>

8@property (nonatomic, assign) IBOutlet NSWindow *window;

@@ -36,7 +36,7 @@ extern void withWebView(WKWebView *, HsStablePtr);

36 [theConfiguration.preferences setValue:@YES forKey:@"developerExtrasEnabled"];

37 WKWebView *webView = [[WKWebView alloc] initWithFrame: [_window.contentView frame] configuration:theConfiguration];

38 [_window setContentView:webView];

39− withWebView(webView, _handler);

39+ callWithWebView(webView, _handler);

40}

41

42-(void)applicationDidFinishLaunching:(NSNotification *)notification {

jsaddle-wkwebview/cbits-uikit/AppDelegate.m+122−2

@@ -1,55 +1,175 @@

1#import "AppDelegate.h"

2#import "ViewController.h"

3+#import <UserNotifications/UserNotifications.h>

4+#import <stdint.h>

3

5

4−@interface AppDelegate ()

6+extern void callIO(HsStablePtr);

7+extern void callWithCString(const char * _Nonnull, HsStablePtr);

5

8

9+@interface AppDelegate ()

6

10

7@end

11@end

8

12

9HsStablePtr globalHandler = 0;

13HsStablePtr globalHandler = 0;

14+HsStablePtr global_willFinishLaunchingWithOptions = 0;

15+HsStablePtr global_didFinishLaunchingWithOptions = 0;

16+HsStablePtr global_applicationDidBecomeActive = 0;

17+HsStablePtr global_applicationWillResignActive = 0;

18+HsStablePtr global_applicationDidEnterBackground = 0;

19+HsStablePtr global_applicationWillEnterForeground = 0;

20+HsStablePtr global_applicationWillTerminate = 0;

21+HsStablePtr global_applicationSignificantTimeChange = 0;

22+HsStablePtr global_applicationUniversalLink = 0;

23+uint64_t global_requestAuthorizationWithOptions = 0;

24+uint64_t global_requestAuthorizationOptionBadge = 0;

25+uint64_t global_requestAuthorizationOptionSound = 0;

26+uint64_t global_requestAuthorizationOptionAlert = 0;

27+uint64_t global_requestAuthorizationOptionCarPlay = 0;

28+uint64_t global_registerForRemoteNotifications = 0;

29+HsStablePtr global_didRegisterForRemoteNotificationsWithDeviceToken = 0;

30+HsStablePtr global_didFailToRegisterForRemoteNotificationsWithError = 0;

10

31

11@implementation AppDelegate

32@implementation AppDelegate

12

33

34+- (BOOL)application:(UIApplication *)application willFinishLaunchingWithOptions:(NSDictionary *)launchOptions {

35+ // Tells the delegate that the launch process has begun but that state restoration has not yet occurred.

36+ callIO(global_willFinishLaunchingWithOptions);

37+ return YES;

38+}

39+

13- (BOOL)application:(UIApplication *)application didFinishLaunchingWithOptions:(NSDictionary *)launchOptions {

40- (BOOL)application:(UIApplication *)application didFinishLaunchingWithOptions:(NSDictionary *)launchOptions {

41+ // Tells the delegate that the launch process is almost done and the app is almost ready to run.

14 self.window = [[UIWindow alloc] initWithFrame:[[UIScreen mainScreen] bounds]];

42 self.window = [[UIWindow alloc] initWithFrame:[[UIScreen mainScreen] bounds]];

15 // Override point for customization after application launch.

43 // Override point for customization after application launch.

16 self.window.rootViewController = [[ViewController alloc] initWithHandler:globalHandler];

44 self.window.rootViewController = [[ViewController alloc] initWithHandler:globalHandler];

17 self.window.backgroundColor = [UIColor whiteColor];

45 self.window.backgroundColor = [UIColor whiteColor];

18 [self.window makeKeyAndVisible];

46 [self.window makeKeyAndVisible];

47+ UNUserNotificationCenter* center = [UNUserNotificationCenter currentNotificationCenter];

48+ center.delegate = self;

49+ if (global_requestAuthorizationWithOptions) {

50+ UNAuthorizationOptions options = (UNAuthorizationOptions)0;

51+ if (global_requestAuthorizationOptionBadge) {

52+ options = options | UNAuthorizationOptionBadge;

53+ }

54+ if (global_requestAuthorizationOptionSound) {

55+ options = options | UNAuthorizationOptionSound;

56+ }

57+ if (global_requestAuthorizationOptionAlert) {

58+ options = options | UNAuthorizationOptionAlert;

59+ }

60+ if (global_requestAuthorizationOptionCarPlay) {

61+ options = options | UNAuthorizationOptionCarPlay;

62+ }

63+ [center requestAuthorizationWithOptions:(options)

64+ completionHandler:^(BOOL granted, NSError * _Nullable error) {

65+ // Handler used to alter application behavior based on types of notifications authorized

66+ }];

67+ if (global_registerForRemoteNotifications) {

68+ [application registerForRemoteNotifications];

69+ }

70+ }

71+ callIO(global_didFinishLaunchingWithOptions);

19 return YES;

72 return YES;

20}

73}

21

74

22- (void)applicationWillResignActive:(UIApplication *)application {

75- (void)applicationWillResignActive:(UIApplication *)application {

23 // Sent when the application is about to move from active to inactive state. This can occur for certain types of temporary interruptions (such as an incoming phone call or SMS message) or when the user quits the application and it begins the transition to the background state.

76 // Sent when the application is about to move from active to inactive state. This can occur for certain types of temporary interruptions (such as an incoming phone call or SMS message) or when the user quits the application and it begins the transition to the background state.

24 // Use this method to pause ongoing tasks, disable timers, and invalidate graphics rendering callbacks. Games should use this method to pause the game.

77 // Use this method to pause ongoing tasks, disable timers, and invalidate graphics rendering callbacks. Games should use this method to pause the game.

78+ callIO(global_applicationWillResignActive);

25}

79}

26

80

27

81

28- (void)applicationDidEnterBackground:(UIApplication *)application {

82- (void)applicationDidEnterBackground:(UIApplication *)application {

29 // Use this method to release shared resources, save user data, invalidate timers, and store enough application state information to restore your application to its current state in case it is terminated later.

83 // Use this method to release shared resources, save user data, invalidate timers, and store enough application state information to restore your application to its current state in case it is terminated later.

30 // If your application supports background execution, this method is called instead of applicationWillTerminate: when the user quits.

84 // If your application supports background execution, this method is called instead of applicationWillTerminate: when the user quits.

85+ callIO(global_applicationDidEnterBackground);

31}

86}

32

87

33

88

34- (void)applicationWillEnterForeground:(UIApplication *)application {

89- (void)applicationWillEnterForeground:(UIApplication *)application {

35 // Called as part of the transition from the background to the active state; here you can undo many of the changes made on entering the background.

90 // Called as part of the transition from the background to the active state; here you can undo many of the changes made on entering the background.

91+ callIO(global_applicationWillEnterForeground);

36}

92}

37

93

38

94

39- (void)applicationDidBecomeActive:(UIApplication *)application {

95- (void)applicationDidBecomeActive:(UIApplication *)application {

40 // Restart any tasks that were paused (or not yet started) while the application was inactive. If the application was previously in the background, optionally refresh the user interface.

96 // Restart any tasks that were paused (or not yet started) while the application was inactive. If the application was previously in the background, optionally refresh the user interface.

97+ callIO(global_applicationDidBecomeActive);

41}

98}

42

99

43

100

44- (void)applicationWillTerminate:(UIApplication *)application {

101- (void)applicationWillTerminate:(UIApplication *)application {

45 // Called when the application is about to terminate. Save data if appropriate. See also applicationDidEnterBackground:.

102 // Called when the application is about to terminate. Save data if appropriate. See also applicationDidEnterBackground:.

103+ callIO(global_applicationWillTerminate);

104+}

105+

106+- (void)application:(UIApplication *)application didRegisterForRemoteNotificationsWithDeviceToken:(NSData *)deviceToken {

107+ // Tells the delegate that the app successfully registered with Apple Push Notification service (APNs).

108+ NSString *deviceTokenString = [deviceToken base64EncodedStringWithOptions: 0];

109+ callWithCString([deviceTokenString UTF8String], global_didRegisterForRemoteNotificationsWithDeviceToken);

110+}

111+

112+- (void)application:(UIApplication *)application didFailToRegisterForRemoteNotificationsWithError:(NSError *)error {

113+ // Sent to the delegate when Apple Push Notification service cannot successfully complete the registration process.

114+ NSString *errorString = [error localizedDescription];

115+ callWithCString([errorString UTF8String], global_didFailToRegisterForRemoteNotificationsWithError);

116+}

117+

118+- (void)applicationSignificantTimeChange:(UIApplication *)application {

119+ // Tells the delegate when there is a significant change in the time.

120+ callIO(global_applicationSignificantTimeChange);

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;

46}

131}

47

132

48@end

133@end

49

134

50−void runInWKWebView(HsStablePtr handler, const char * _Nonnull progName) {

135+void runInWKWebView(HsStablePtr handler,

136+ const char * _Nonnull progName,

137+ HsStablePtr hs_willFinishLaunchingWithOptions,

138+ HsStablePtr hs_didFinishLaunchingWithOptions,

139+ HsStablePtr hs_applicationDidBecomeActive,

140+ HsStablePtr hs_applicationWillResignActive,

141+ HsStablePtr hs_applicationDidEnterBackground,

142+ HsStablePtr hs_applicationWillEnterForeground,

143+ HsStablePtr hs_applicationWillTerminate,

144+ HsStablePtr hs_applicationSignificantTimeChange,

145+ HsStablePtr hs_applicationUniversalLink,

146+ const uint64_t hs_requestAuthorizationWithOptions,

147+ const uint64_t hs_requestAuthorizationOptionBadge,

148+ const uint64_t hs_requestAuthorizationOptionSound,

149+ const uint64_t hs_requestAuthorizationOptionAlert,

150+ const uint64_t hs_requestAuthorizationOptionCarPlay,

151+ const uint64_t hs_registerForRemoteNotifications,

152+ HsStablePtr hs_didRegisterForRemoteNotificationsWithDeviceToken,

153+ HsStablePtr hs_didFailToRegisterForRemoteNotificationsWithError) {

51 @autoreleasepool {

154 @autoreleasepool {

52 globalHandler = handler;

155 globalHandler = handler;

156+ global_willFinishLaunchingWithOptions = hs_willFinishLaunchingWithOptions;

157+ global_didFinishLaunchingWithOptions = hs_didFinishLaunchingWithOptions;

158+ global_applicationDidBecomeActive = hs_applicationDidBecomeActive;

159+ global_applicationWillResignActive = hs_applicationWillResignActive;

160+ global_applicationDidEnterBackground = hs_applicationDidEnterBackground;

161+ global_applicationWillEnterForeground = hs_applicationWillEnterForeground;

162+ global_applicationWillTerminate = hs_applicationWillTerminate;

163+ global_applicationSignificantTimeChange = hs_applicationSignificantTimeChange;

164+ global_applicationUniversalLink = hs_applicationUniversalLink;

165+ global_requestAuthorizationWithOptions = hs_requestAuthorizationWithOptions;

166+ global_requestAuthorizationOptionBadge = hs_requestAuthorizationOptionBadge;

167+ global_requestAuthorizationOptionSound = hs_requestAuthorizationOptionSound;

168+ global_requestAuthorizationOptionAlert = hs_requestAuthorizationOptionAlert;

169+ global_requestAuthorizationOptionCarPlay = hs_requestAuthorizationOptionCarPlay;

170+ global_registerForRemoteNotifications = hs_registerForRemoteNotifications;

171+ global_didRegisterForRemoteNotificationsWithDeviceToken = hs_didRegisterForRemoteNotificationsWithDeviceToken;

172+ global_didFailToRegisterForRemoteNotificationsWithError = hs_didFailToRegisterForRemoteNotificationsWithError;

53 const char * _Nonnull argv [] = {"", 0};

173 const char * _Nonnull argv [] = {"", 0};

54 UIApplicationMain(0, argv, nil, NSStringFromClass([AppDelegate class]));

174 UIApplicationMain(0, argv, nil, NSStringFromClass([AppDelegate class]));

55 }

175 }

jsaddle-wkwebview/cbits-uikit/ViewController.m+2−2

@@ -1,6 +1,6 @@

1#import "ViewController.h"

2

3−extern void withWebView(WKWebView *, HsStablePtr);

3+extern void callWithWebView(WKWebView *, HsStablePtr);

4

5@interface ViewController ()

6

@@ -27,7 +27,7 @@ extern void withWebView(WKWebView *, HsStablePtr);

27

28- (void)viewDidLoad {

29 [super viewDidLoad];

30− withWebView(_webView, _handler);

30+ callWithWebView(_webView, _handler);

31}

32

33

jsaddle-wkwebview/default.nix+3−3

@@ -1,12 +1,12 @@

1−{ mkDerivation, stdenv, aeson, base, bytestring, jsaddle

1+{ mkDerivation, stdenv, aeson, base, bytestring, jsaddle, data-default

2, buildPackages

3}:

4

5mkDerivation {

6 pname = "jsaddle-wkwebview";

7− version = "0.8.3.2";

7+ version = "0.9.0.0";

8 src = ./.;

9− libraryHaskellDepends = [ aeson base bytestring jsaddle ]

9+ libraryHaskellDepends = [ aeson base bytestring jsaddle data-default ]

10 # should use `librarySystemDepends` but it is not propagated

11 ++ (with buildPackages; [

12 darwin.libobjc

jsaddle-wkwebview/jsaddle-wkwebview.cabal+16−8

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

1name: jsaddle-wkwebview

2−version: 0.8.3.2

2+version: 0.9.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

@@ -14,6 +14,10 @@ description:

14category: Web, Javascript

15author: Hamish Mackenzie

16

17+flag include-app-delegate

18+ description: Include default AppDelegate C sources.

19+ default: True

20+

17source-repository head

21source-repository head

18 type: git

22 type: git

19 location: https://github.com/ghcjs/jsaddle

23 location: https://github.com/ghcjs/jsaddle

@@ -26,7 +30,9 @@ library

26 aeson >=0.8.0.2 && <1.3,

30 aeson >=0.8.0.2 && <1.3,

27 base <5,

31 base <5,

28 bytestring >=0.10.6.0 && <0.11,

32 bytestring >=0.10.6.0 && <0.11,

29− jsaddle >= 0.8.0.0 && <0.9

33+ jsaddle >= 0.9.0.0 && <0.10,

34+ data-default,

35+ containers

30 default-language: Haskell2010

36 default-language: Haskell2010

31 hs-source-dirs: src

37 hs-source-dirs: src

32 frameworks: Foundation, WebKit

38 frameworks: Foundation, WebKit

@@ -38,11 +44,13 @@ library

38 else

44 else

39 hs-source-dirs: src-ghc

45 hs-source-dirs: src-ghc

40 if os(ios)

46 if os(ios)

41− frameworks: UIKit

47+ frameworks: UIKit, UserNotifications

48+ if flag(include-app-delegate)

42− c-sources:

49+ c-sources:

43− cbits-uikit/AppDelegate.m

50+ cbits-uikit/AppDelegate.m

44− cbits-uikit/ViewController.m

51+ cbits-uikit/ViewController.m

45 else

52 else

46 frameworks: Cocoa

53 frameworks: Cocoa

54+ if flag(include-app-delegate)

47− c-sources:

55+ c-sources:

48− cbits-cocoa/AppDelegate.m

56+ cbits-cocoa/AppDelegate.m

jsaddle-wkwebview/src-ghc/Language/Javascript/JSaddle/WKWebView.hs+138−9

@@ -3,32 +3,161 @@ module Language.Javascript.JSaddle.WKWebView

3 , jsaddleMainFile

4 , WKWebView(..)

5 , run

6+ , runWithAppConfig

6 , runFile

7 , runFile

7 , mainBundleResourcePath

8 , mainBundleResourcePath

9+ , AppDelegateConfig (..)

10+ , AppDelegateNotificationConfig (..)

11+ , AuthorizationOption (..)

8 ) where

12 ) where

9

13

10import Data.ByteString (ByteString)

14import Data.ByteString (ByteString)

15+import Data.Default (Default, def)

16+import Data.Set (Set)

17+import qualified Data.Set as Set

18+import Data.Word

19+import Foreign.Marshal.Utils (fromBool)

11import Language.Javascript.JSaddle.WKWebView.Internal (jsaddleMain, jsaddleMainFile, WKWebView(..), mainBundleResourcePath)

20import Language.Javascript.JSaddle.WKWebView.Internal (jsaddleMain, jsaddleMainFile, WKWebView(..), mainBundleResourcePath)

12import System.Environment (getProgName)

21import System.Environment (getProgName)

13import Foreign.C.String (CString, withCString)

22import Foreign.C.String (CString, withCString)

14import Foreign.StablePtr (StablePtr, newStablePtr)

23import Foreign.StablePtr (StablePtr, newStablePtr)

15import Language.Javascript.JSaddle (JSM)

24import Language.Javascript.JSaddle (JSM)

16

25

17−foreign import ccall runInWKWebView :: StablePtr (WKWebView -> IO ()) -> CString -> IO ()

26+foreign import ccall runInWKWebView

27+ :: StablePtr (WKWebView -> IO ())

28+ -> CString

29+ -> StablePtr (IO ()) -- willFinishLaunchingWithOptions

30+ -> StablePtr (IO ()) -- didFinishLaunchingWithOptions

31+ -> StablePtr (IO ()) -- applicationDidBecomeActive

32+ -> StablePtr (IO ()) -- applicationWillResignActive

33+ -> StablePtr (IO ()) -- applicationDidEnterBackground

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

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

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

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

38+ -> Word64 -- whether to run requestAuthorizationWithOptions

39+ -> Word64 -- Ask for Badge authorization

40+ -> Word64 -- Ask for Sound authorization

41+ -> Word64 -- Ask for Alert authorization

42+ -> Word64 -- Ask for CarPlay authorization

43+ -> Word64 -- registerForRemoteNotifications

44+ -> StablePtr (CString -> IO ()) -- didRegisterForRemoteNotificationsWithDeviceToken

45+ -> StablePtr (CString -> IO ()) -- didFailToRegisterForRemoteNotificationsWithError

46+ -> IO ()

47+

48+data AppDelegateConfig = AppDelegateConfig

49+ { _appDelegateConfig_willFinishLaunchingWithOptions :: IO ()

50+ , _appDelegateConfig_didFinishLaunchingWithOptions :: IO ()

51+ , _appDelegateConfig_applicationDidBecomeActive :: IO ()

52+ , _appDelegateConfig_applicationWillResignActive :: IO ()

53+ , _appDelegateConfig_applicationDidEnterBackground :: IO ()

54+ , _appDelegateConfig_applicationWillEnterForeground :: IO ()

55+ , _appDelegateConfig_applicationWillTerminate :: IO ()

56+ , _appDelegateConfig_applicationSignificantTimeChange :: IO ()

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

58+ , _appDelegateConfig_appDelegateNotificationConfig :: AppDelegateNotificationConfig

59+ }

60+

61+instance Default AppDelegateConfig where

62+ def = AppDelegateConfig

63+ { _appDelegateConfig_willFinishLaunchingWithOptions = return ()

64+ , _appDelegateConfig_didFinishLaunchingWithOptions = return ()

65+ , _appDelegateConfig_applicationDidBecomeActive = return ()

66+ , _appDelegateConfig_applicationWillResignActive = return ()

67+ , _appDelegateConfig_applicationDidEnterBackground = return ()

68+ , _appDelegateConfig_applicationWillEnterForeground = return ()

69+ , _appDelegateConfig_applicationWillTerminate = return ()

70+ , _appDelegateConfig_applicationSignificantTimeChange = return ()

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

72+ , _appDelegateConfig_appDelegateNotificationConfig = def

73+ }

74+

75+data AuthorizationOption = AuthorizationOption_Badge

76+ | AuthorizationOption_Sound

77+ | AuthorizationOption_Alert

78+ | AuthorizationOption_CarPlay

79+ deriving (Show, Read, Eq, Ord)

80+

81+data AppDelegateNotificationConfig = AppDelegateNotificationConfig

82+ { _appDelegateNotificationConfig_requestAuthorizationWithOptions :: Maybe (Set AuthorizationOption)

83+ , _appDelegateNotificationConfig_registerForRemoteNotifications :: Bool

84+ , _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken :: CString -> IO ()

85+ , _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError :: CString -> IO ()

86+ }

87+

88+instance Default AppDelegateNotificationConfig where

89+ def = AppDelegateNotificationConfig

90+ { _appDelegateNotificationConfig_requestAuthorizationWithOptions = Nothing

91+ , _appDelegateNotificationConfig_registerForRemoteNotifications = False

92+ , _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken = \_ -> return ()

93+ , _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError = \_ -> return ()

94+ }

95+

18

96

19-- | Run JSaddle in a WKWebView

97-- | Run JSaddle in a WKWebView

20run :: JSM () -> IO ()

98run :: JSM () -> IO ()

21−run f = do

99+run = run' Nothing def

22− handler <- newStablePtr (jsaddleMain f)

100+

23− progName <- getProgName

101+-- | Run JSaddle in a WKWebView

24− withCString progName $ runInWKWebView handler

102+runWithAppConfig :: AppDelegateConfig -> JSM () -> IO ()

103+runWithAppConfig = run' Nothing

25

104

26-- | Run JSaddle in a WKWebView first loading the specified file

105-- | Run JSaddle in a WKWebView first loading the specified file

27-- from the mainBundle (relative to the resourcePath).

106-- from the mainBundle (relative to the resourcePath).

28runFile :: ByteString -- ^ The file to navigate to.

107runFile :: ByteString -- ^ The file to navigate to.

29 -> ByteString -- ^ The path to allow read access to.

108 -> ByteString -- ^ The path to allow read access to.

109+ -> AppDelegateConfig

30− -> JSM () -> IO ()

110+ -> JSM ()

111+ -> IO ()

31−runFile url allowing f = do

112+runFile url allowing = run' $ Just (url, allowing)

113+

114+run' :: Maybe (ByteString, ByteString)

115+ -> AppDelegateConfig

116+ -> JSM ()

117+ -> IO ()

118+run' mUrl cfg f = do

119+ handler <- case mUrl of

32− handler <- newStablePtr (jsaddleMainFile url allowing f)

120+ Just (url, allowing) -> newStablePtr (jsaddleMainFile url allowing f)

121+ Nothing -> newStablePtr (jsaddleMain f)

33 progName <- getProgName

122 progName <- getProgName

123+

124+ -- AppDelegate callbacks

125+ willFinishLaunchingWithOptions <- newStablePtr $ _appDelegateConfig_willFinishLaunchingWithOptions cfg

126+ didFinishLaunchingWithOptions <- newStablePtr $ _appDelegateConfig_didFinishLaunchingWithOptions cfg

127+ applicationDidBecomeActive <- newStablePtr $ _appDelegateConfig_applicationDidBecomeActive cfg

128+ applicationWillResignActive <- newStablePtr $ _appDelegateConfig_applicationWillResignActive cfg

129+ applicationDidEnterBackground <- newStablePtr $ _appDelegateConfig_applicationDidEnterBackground cfg

130+ applicationWillEnterForeground <- newStablePtr $ _appDelegateConfig_applicationWillEnterForeground cfg

131+ applicationWillTerminate <- newStablePtr $ _appDelegateConfig_applicationWillTerminate cfg

132+ applicationSignificantTimeChange <- newStablePtr $ _appDelegateConfig_applicationSignificantTimeChange cfg

133+ applicationUniversalLink <- newStablePtr $ _appDelegateConfig_applicationUniversalLink cfg

134+

135+ -- AppDelegate notification configuration

136+ let ncfg = _appDelegateConfig_appDelegateNotificationConfig cfg

137+ (requestAuthorizationWithOptions, authorizationOptions) =

138+ case _appDelegateNotificationConfig_requestAuthorizationWithOptions ncfg of

139+ Nothing -> (False, Set.empty)

140+ Just opts -> (True, opts)

141+ registerForRemoteNotifications = _appDelegateNotificationConfig_registerForRemoteNotifications ncfg

142+ didRegisterForRemoteNotificationsWithDeviceToken <- newStablePtr $ _appDelegateNotificationConfig_didRegisterForRemoteNotificationsWithDeviceToken ncfg

143+ didFailToRegisterForRemoteNotificationsWithError <- newStablePtr $ _appDelegateNotificationConfig_didFailToRegisterForRemoteNotificationsWithError ncfg

34− withCString progName $ runInWKWebView handler

144+ withCString progName $ \pn -> runInWKWebView

145+ handler

146+ pn

147+ willFinishLaunchingWithOptions

148+ didFinishLaunchingWithOptions

149+ applicationDidBecomeActive

150+ applicationWillResignActive

151+ applicationDidEnterBackground

152+ applicationWillEnterForeground

153+ applicationWillTerminate

154+ applicationSignificantTimeChange

155+ applicationUniversalLink

156+ (fromBool requestAuthorizationWithOptions)

157+ (fromBool $ Set.member AuthorizationOption_Badge authorizationOptions)

158+ (fromBool $ Set.member AuthorizationOption_Sound authorizationOptions)

159+ (fromBool $ Set.member AuthorizationOption_Alert authorizationOptions)

160+ (fromBool $ Set.member AuthorizationOption_CarPlay authorizationOptions)

161+ (fromBool registerForRemoteNotifications)

162+ didRegisterForRemoteNotificationsWithDeviceToken

163+ didFailToRegisterForRemoteNotificationsWithError

jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hs+18−5

@@ -30,7 +30,9 @@ newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)

30foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()

31foreign export ccall jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()

32foreign export ccall jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()

33−foreign export ccall withWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

33+foreign export ccall callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

34+foreign export ccall callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()

35+foreign export ccall callIO :: StablePtr (IO ()) -> IO ()

34foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO ()

36foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO ()

35foreign import ccall loadHTMLString :: WKWebView -> CString -> IO ()

37foreign import ccall loadHTMLString :: WKWebView -> CString -> IO ()

36foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO ()

38foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO ()

@@ -81,7 +83,7 @@ jsaddleResult ptrHandler s = do

81 processResult <- deRefStablePtr ptrHandler

83 processResult <- deRefStablePtr ptrHandler

82 result <- packCString s

84 result <- packCString s

83 case decode (fromStrict result) of

85 case decode (fromStrict result) of

84− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result

86+ Nothing -> error $ "jsaddle Results decode failed : " <> show result

85 Just r -> processResult r

87 Just r -> processResult r

86

88

87jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()

89jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()

@@ -89,17 +91,27 @@ jsaddleSyncResult ptrHandler jsaddleHandler s = do

89 syncProcessResult <- deRefStablePtr ptrHandler

91 syncProcessResult <- deRefStablePtr ptrHandler

90 result <- packCString s

92 result <- packCString s

91 case decode (fromStrict result) of

93 case decode (fromStrict result) of

92− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result

94+ Nothing -> error $ "jsaddle Results decode failed : " <> show result

93 Just r -> do -- void . forkIO $ do

95 Just r -> do -- void . forkIO $ do

94 batch <- syncProcessResult r

96 batch <- syncProcessResult r

95 useAsCString (toStrict $ encode batch) $

97 useAsCString (toStrict $ encode batch) $

96 completeSync jsaddleHandler

98 completeSync jsaddleHandler

97

99

98−withWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

100+callWithWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

99−withWebView webView ptrF = do

101+callWithWebView webView ptrF = do

100 f <- deRefStablePtr ptrF

102 f <- deRefStablePtr ptrF

101 f webView

103 f webView

102

104

105+callWithCString :: CString -> StablePtr (CString -> IO ()) -> IO ()

106+callWithCString c fptr = do

107+ f <- deRefStablePtr fptr

108+ f c

109+

110+callIO :: StablePtr (IO ()) -> IO ()

111+callIO ptr = do

112+ f <- deRefStablePtr ptr

113+ f

114+

103jsaddleJs :: ByteString

115jsaddleJs :: ByteString

104jsaddleJs = ghcjsHelpers <> "\

116jsaddleJs = ghcjsHelpers <> "\

105 \runJSaddleBatch = (function() {\n\

117 \runJSaddleBatch = (function() {\n\

@@ -128,3 +140,4 @@ mainBundleResourcePath = do

128 if bs == nullPtr

140 if bs == nullPtr

129 then return Nothing

141 then return Nothing

130 else Just <$> packCString bs

142 else Just <$> packCString bs

143+

jsaddle/default.nix+1−1

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

5}:

6mkDerivation {

7 pname = "jsaddle";

8− version = "0.8.0.1";

8+ version = "0.9.0.0";

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

10 libraryHaskellDepends = [

11 aeson attoparsec base base64-bytestring bytestring containers

jsaddle/jsaddle.cabal+1−1

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

1name: jsaddle

2−version: 0.8.3.2

2+version: 0.9.0.0

3cabal-version: >=1.10

4build-type: Simple

5license: MIT

jsaddle/src/Language/Javascript/JSaddle/Run.hs+32−34

@@ -1,3 +1,4 @@

1+{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE CPP #-}

2{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

@@ -49,7 +50,7 @@ import Control.Concurrent.STM.TChan

49import Control.Concurrent.STM.TVar

50import Control.Concurrent.STM.TVar

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

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

51import Control.Concurrent.MVar

52import Control.Concurrent.MVar

52− (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar)

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

53

54

54import System.IO.Unsafe (unsafeInterleaveIO)

55import System.IO.Unsafe (unsafeInterleaveIO)

55import System.Mem.Weak (addFinalizer)

56import System.Mem.Weak (addFinalizer)

@@ -61,7 +62,7 @@ import Data.Time.Clock (getCurrentTime,diffUTCTime)

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

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

62

63

63import Language.Javascript.JSaddle.Types

64import Language.Javascript.JSaddle.Types

64− (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),

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

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

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

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

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

67-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)

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

@@ -152,7 +153,6 @@ runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results ->

152runJavaScript sendBatch entryPoint = do

153runJavaScript sendBatch entryPoint = do

153 startTime' <- getCurrentTime

154 startTime' <- getCurrentTime

154 recvMVar <- newEmptyMVar

155 recvMVar <- newEmptyMVar

155− syncSendBatch <- newEmptyMVar

156 lastAsyncBatch <- newEmptyMVar

157 commandChan <- newTChanIO

158 callbacks <- newTVarIO M.empty

@@ -176,7 +176,8 @@ runJavaScript sendBatch entryPoint = do

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

177 processResults syncCallbacks = \case

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

179− (Callback f this a) -> do

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

180+ putMVar recvMVar (n, br)

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

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

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

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

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

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

@@ -185,27 +186,20 @@ runJavaScript sendBatch entryPoint = do

185 Nothing -> liftIO $ putStrLn "Callback called after it was freed"

186 Nothing -> liftIO $ putStrLn "Callback called after it was freed"

186 Just cb -> void . forkIO $ do

187 Just cb -> void . forkIO $ do

187 runReaderT (unJSM $ cb f' this' args) ctx

188 runReaderT (unJSM $ cb f' this' args) ctx

188− when syncCallbacks $ do

189+ when syncCallbacks $

189 doSendAsyncCommand ctx EndSyncBlock

190 doSendAsyncCommand ctx EndSyncBlock

191+ Duplicate nBatch nExpected -> do

192+ putStrLn $ "Error : Unexpected Duplicate. syncCallbacks=" <> show syncCallbacks <>

193+ " nBatch=" <> show nBatch <> " nExpected=" <> show nExpected

190− void $ doSendCommand ctx Sync

194+ void $ doSendCommand ctx Sync

191− Duplicate -> error "Error : Unexpected Duplicate"

192− m -> putMVar recvMVar m

195+ BatchResults n br -> putMVar recvMVar (n, br)

193 asyncResults :: Results -> IO ()

196 asyncResults :: Results -> IO ()

197+ asyncResults results =

194− asyncResults = processResults False

198+ void . forkIO $ processResults False results

195 syncResults :: Results -> IO Batch

199 syncResults :: Results -> IO Batch

196 syncResults results = do

200 syncResults results = do

197− existing <- tryTakeMVar syncSendBatch

201+ void . forkIO $ processResults True results

198− when (isJust existing) $ error "Error : Unexpected Sync Results"

199− tryTakeMVar lastAsyncBatch >>= \case

202+ readMVar lastAsyncBatch

200− Just lastAsync -> processResults True results >> return lastAsync

201− Nothing -> do

202− nextBatch <- newEmptyMVar

203− putMVar syncSendBatch (\batch -> do

204− existing <- tryTakeMVar nextBatch

205− when (isJust existing) $ error "Error : Unexpected Sync Results"

206− putMVar nextBatch batch)

207− processResults True results

208− takeMVar nextBatch

209 logInfo s =

203 logInfo s =

210 readIORef loggingEnabled >>= \case

204 readIORef loggingEnabled >>= \case

211 True -> do

205 True -> do

@@ -215,28 +209,32 @@ runJavaScript sendBatch entryPoint = do

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

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

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

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

217 False -> return ()

211 False -> return ()

218− _ <- forkIO . forM_ [1..] $ \nBatch ->

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

219 readBatch nBatch commandChan >>= \case

213 readBatch nBatch commandChan >>= \case

220 (batch@(Batch cmds _ _), resultMVars) -> do

214 (batch@(Batch cmds _ _), resultMVars) -> do

221 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))

215 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))

222− tryTakeMVar syncSendBatch >>= \case

216+ _ <- tryTakeMVar lastAsyncBatch

223− Just send -> send batch

224− Nothing -> do

225− putMVar lastAsyncBatch batch

217+ putMVar lastAsyncBatch batch

226− sendBatch batch

218+ sendBatch batch

227− takeMVar recvMVar >>= \r -> do

219+ takeResult recvMVar nBatch >>= \case

228− _ <- tryTakeMVar lastAsyncBatch

220+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"

229− case r of

230− Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

221+ (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

231− | otherwise -> zipWithM_ putMVar resultMVars results

222+ | otherwise -> zipWithM_ putMVar resultMVars results

232− Failure results exception -> do

223+ (_, Failure results exception) -> do

233 -- The exception will only be rethrown in Haskell if/when one of the

224 -- The exception will only be rethrown in Haskell if/when one of the

234 -- missing results (if any) is evaluated.

225 -- missing results (if any) is evaluated.

235 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

226 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

236 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

227 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

237− _ -> error "Unexpected jsaddle results"

238 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

228 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

239 where

229 where

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

231+ numberForeverFromM_ !n f = do

232+ f n

233+ numberForeverFromM_ (succ n) f

234+ takeResult recvMVar nBatch =

235+ takeMVar recvMVar >>= \case

236+ (n, _) | n < nBatch -> takeResult recvMVar nBatch

237+ r -> return r

240 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])

238 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])

241 readBatch nBatch chan = do

239 readBatch nBatch chan = do

242 first <- atomically $ readTChan chan -- We want at least one command to send

240 first <- atomically $ readTChan chan -- We want at least one command to send

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+25−11

@@ -44,6 +44,8 @@ initState = "\

44 \ jsaddle_values.set(4, window);\n\

45 \ var jsaddle_index = 100;\n\

46 \ var expectedBatch = 1;\n\

47+ \ var lastResults = [0, {}];\n\

48+ \ var inCallback = 0;\n\

47 \"

49 \"

48

50

49runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString

51runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString

@@ -52,6 +54,7 @@ runBatch send sendSync = "\

52 \ var processBatch = function(timestamp) {\n\

54 \ var processBatch = function(timestamp) {\n\

53 \ var batch = firstBatch;\n\

55 \ var batch = firstBatch;\n\

54 \ var results = [];\n\

56 \ var results = [];\n\

57+ \ inCallback++;\n\

55 \ try {\n\

58 \ try {\n\

56 \ syncDepth = initialSyncDepth || 0;\n\

59 \ syncDepth = initialSyncDepth || 0;\n\

57 \ for(;;){\n\

60 \ for(;;){\n\

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

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

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

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

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

110 \ }\n\

113 \ }\n\

111− \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\

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

112 \ })})();\n\

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

113 \ break;\n\

116 \ break;\n\

114 \ case \"NewSyncCallback\":\n\

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

@@ -125,9 +128,13 @@ runBatch send sendSync = "\

125 \ }\n" <> (

128 \ }\n" <> (

126 case sendSync of

129 case sendSync of

127 Just s ->

130 Just s ->

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

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

133+ \ } else {\n\

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

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

135+ \ }\n"

129 Nothing ->

136 Nothing ->

130− " " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n"

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

131 ) <>

138 ) <>

132 " })})();\n\

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

133 \ break;\n\

140 \ break;\n\

@@ -243,29 +250,35 @@ runBatch send sendSync = "\

243 \ }\n\

250 \ }\n\

244 \ }\n\

251 \ }\n\

245 \ }\n\

252 \ }\n\

246− \ if(syncDepth === 0) {\n\

253+ \ if(syncDepth <= 0) {\n\

247− \ " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

254+ \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

255+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\

248 \ break;\n\

256 \ break;\n\

249 \ } else {\n" <> (

257 \ } else {\n" <> (

250 case sendSync of

258 case sendSync of

251 Just s ->

259 Just s ->

252− " batch = " <> s "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

260+ " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

261+ \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

253 \ results = [];\n"

262 \ results = [];\n"

254 Nothing ->

263 Nothing ->

255− " " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

264+ " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": results}]}" <> "\n\

256 \ break;\n"

265 \ break;\n"

257 ) <>

266 ) <>

258 " }\n\

267 " }\n\

259 \ } else {\n\

268 \ } else {\n\

260− \ if(syncDepth === 0) {\n\

269+ \ if(syncDepth <= 0) {\n\

261 \ break;\n\

270 \ break;\n\

262 \ } else {\n" <> (

271 \ } else {\n" <> (

263 case sendSync of

272 case sendSync of

264 Just s ->

273 Just s ->

274+ " if(batch[2] === expectedBatch - 1) {\n\

275+ \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

276+ \ } else {\n\

265− " batch = " <> s "{\"tag\": \"Duplicate\"}" <> "\n\

277+ \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\

278+ \ }\n\

266 \ results = [];\n"

279 \ results = [];\n"

267 Nothing ->

280 Nothing ->

268− " " <> send "{\"tag\": \"Duplicate\"}" <> "\n\

281+ " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\

269 \ break;\n"

282 \ break;\n"

270 ) <>

283 ) <>

271 " }\n\

284 " }\n\

@@ -275,8 +288,9 @@ runBatch send sendSync = "\

275 \ catch (err) {\n\

288 \ catch (err) {\n\

276 \ var n = ++jsaddle_index;\n\

289 \ var n = ++jsaddle_index;\n\

277 \ jsaddle_values.set(n, err);\n\

290 \ jsaddle_values.set(n, err);\n\

278− \ " <> send "{\"tag\": \"Failure\", \"contents\": [results,n]}" <> "\n\

291+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [results, n]}]}" <> "\n\

279 \ }\n\

292 \ }\n\

293+ \ inCallback--;\n\

280 \ };\n\

294 \ };\n\

281 \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\

295 \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\

282 \ window.requestAnimationFrame(processBatch);\n\

296 \ window.requestAnimationFrame(processBatch);\n\

jsaddle/src/Language/Javascript/JSaddle/Types.hs+43−19

@@ -14,6 +14,7 @@

14#endif

15{-# LANGUAGE ConstraintKinds #-}

16{-# LANGUAGE KindSignatures #-}

17+{-# LANGUAGE AllowAmbiguousTypes #-}

17-----------------------------------------------------------------------------

18-----------------------------------------------------------------------------

18--

19--

19-- Module : Language.Javascript.JSaddle.Types

20-- Module : Language.Javascript.JSaddle.Types

@@ -73,6 +74,7 @@ module Language.Javascript.JSaddle.Types (

73 , Command(..)

74 , Command(..)

74 , Batch(..)

75 , Batch(..)

75 , Result(..)

76 , Result(..)

77+ , BatchResults(..)

76 , Results(..)

78 , Results(..)

77#endif

79#endif

78) where

80) where

@@ -87,10 +89,19 @@ import GHCJS.Nullable (Nullable(..))

87import GHCJS.Prim.Internal (JSVal(..), JSValueRef)

89import GHCJS.Prim.Internal (JSVal(..), JSValueRef)

88import Data.JSString.Internal.Type (JSString(..))

90import Data.JSString.Internal.Type (JSString(..))

89import Control.DeepSeq (NFData(..))

91import Control.DeepSeq (NFData(..))

92+import Control.Monad.Trans.Cont (ContT(..))

93+import Control.Monad.Trans.Error (Error(..), ErrorT(..))

94+import Control.Monad.Trans.Except (ExceptT(..))

95+import Control.Monad.Trans.Identity (IdentityT(..))

96+import Control.Monad.Trans.List (ListT(..))

97+import Control.Monad.Trans.Maybe (MaybeT(..))

90import Control.Monad.Trans.Reader (ReaderT(..))

98import Control.Monad.Trans.Reader (ReaderT(..))

91−import Control.Monad.Trans.State.Lazy (StateT(..))

99+import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))

100+import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))

101+import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))

92−import qualified Control.Monad.Trans.State.Strict as Strict

102+import Control.Monad.Trans.State.Strict as Strict (StateT(..))

93− (StateT(..))

103+import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..))

104+import Control.Monad.Trans.Writer.Strict as Strict (WriterT(..))

94import Control.Monad.Trans.Class (MonadTrans(..))

105import Control.Monad.Trans.Class (MonadTrans(..))

95import Control.Monad.Fix (MonadFix)

106import Control.Monad.Fix (MonadFix)

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

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

@@ -191,23 +202,28 @@ type MonadJSM = MonadIO

191#else

202#else

192class (Applicative m, MonadIO m) => MonadJSM m where

203class (Applicative m, MonadIO m) => MonadJSM m where

193 liftJSM' :: JSM a -> m a

204 liftJSM' :: JSM a -> m a

194− {-# MINIMAL liftJSM' #-}

195

205

196−instance MonadJSM JSM where

206+ default liftJSM' :: (MonadJSM m', MonadTrans t) => JSM a' -> t m' a'

197− liftJSM' = id

198− {-# INLINE liftJSM' #-}

199−

200−instance MonadJSM m => MonadJSM (ReaderT e m) where

201− liftJSM' = lift . liftJSM'

207+ liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a)

202 {-# INLINE liftJSM' #-}

208 {-# INLINE liftJSM' #-}

203

209

204−instance MonadJSM m => MonadJSM (StateT r m) where

210+instance MonadJSM JSM where

205− liftJSM' = lift . liftJSM'

211+ liftJSM' = id

206 {-# INLINE liftJSM' #-}

212 {-# INLINE liftJSM' #-}

207

213

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

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

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

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

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

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

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

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

208−instance MonadJSM m => MonadJSM (Strict.StateT r m) where

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

209− liftJSM' = lift . liftJSM'

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

210− {-# INLINE liftJSM' #-}

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

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

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

211

227

212instance MonadRef JSM where

228instance MonadRef JSM where

213 type Ref JSM = Ref IO

229 type Ref JSM = Ref IO

@@ -385,10 +401,18 @@ instance ToJSON Result where

385

401

386instance FromJSON Result

402instance FromJSON Result

387

403

388−data Results = Success [Result]

404+data BatchResults = Success [Result]

389− | Failure [Result] JSValueReceived

405+ | Failure [Result] JSValueReceived

406+ deriving (Show, Generic)

407+

408+instance ToJSON BatchResults where

409+ toEncoding = genericToEncoding defaultOptions

410+

411+instance FromJSON BatchResults

412+

413+data Results = BatchResults Int BatchResults

390− | Duplicate

414+ | Duplicate Int Int

391− | Callback JSValueReceived JSValueReceived [JSValueReceived]

415+ | Callback Int BatchResults JSValueReceived JSValueReceived [JSValueReceived]

392 | ProtocolError Text

416 | ProtocolError Text

393 deriving (Show, Generic)

417 deriving (Show, Generic)

394

418