{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} module Language.Javascript.JSaddle.CLib ( jsaddleInit , NativeCallbacks (..) , AppCallbacks (..) , AppConfig (..) , pokeAppConfig , appConfigToAppCallbacks ) where import Prelude () import Prelude.Compat import Control.Monad (void) import Control.Concurrent (forkIO) import Data.Aeson (encode, decode) import Data.ByteString (useAsCString, packCString) import Data.ByteString.Char8 (unpack) import Data.ByteString.Lazy (ByteString, toStrict, fromStrict) import Data.Default (def, Default) import Data.Text (Text) import qualified Data.Text.Encoding as T import Foreign.C.String (CString, newCString) import Foreign.Ptr (FunPtr, Ptr) import Foreign.Storable (poke) import Foreign.Marshal.Utils (new) import Language.Javascript.JSaddle (JSM) import Language.Javascript.JSaddle.Run (runJavaScript) import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers) import Language.Javascript.JSaddle.CLib.Internal foreign import ccall safe "dynamic" mkCallback :: FunPtr (CString -> IO ()) -> CString -> IO () foreign import ccall safe "wrapper" wrapStartCallback :: IO () -> IO (FunPtr (IO ())) foreign import ccall safe "wrapper" wrapMessageCallback :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) foreign import ccall safe "wrapper" wrapMessageCallback2 :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ())) foreign import ccall safe "wrapper" wrapSyncCallback :: (CString -> IO CString) -> IO (FunPtr (CString -> IO CString)) jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks) jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks) jsaddleInit JSM () jsm FunPtr (CString -> IO ()) evaluateJavascriptAsyncPtr = do let evaluateJavascriptAsync :: CString -> IO () evaluateJavascriptAsync = FunPtr (CString -> IO ()) -> CString -> IO () mkCallback FunPtr (CString -> IO ()) evaluateJavascriptAsyncPtr (Results -> IO () processResult, Results -> IO Batch processSyncResult, IO () start) <- (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ()) runJavaScript (\Batch batch -> ByteString -> (CString -> IO ()) -> IO () forall a. ByteString -> (CString -> IO a) -> IO a useAsCString (ByteString -> ByteString toStrict (ByteString -> ByteString) -> ByteString -> ByteString forall a b. (a -> b) -> a -> b $ ByteString "runJSaddleBatch(" ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> Batch -> ByteString forall a. ToJSON a => a -> ByteString encode Batch batch ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> ByteString ");") CString -> IO () evaluateJavascriptAsync) JSM () jsm FunPtr (IO ()) jsaddleStartPtr <- IO () -> IO (FunPtr (IO ())) wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ())) forall a b. (a -> b) -> a -> b $ IO ThreadId -> IO () forall (f :: * -> *) a. Functor f => f a -> f () void (IO ThreadId -> IO ()) -> IO ThreadId -> IO () forall a b. (a -> b) -> a -> b $ IO () -> IO ThreadId forkIO IO () start FunPtr (CString -> IO ()) jsaddleResultPtr <- (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) wrapMessageCallback ((CString -> IO ()) -> IO (FunPtr (CString -> IO ()))) -> (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) forall a b. (a -> b) -> a -> b $ \CString s -> do Maybe Results result <- ByteString -> Maybe Results forall a. FromJSON a => ByteString -> Maybe a decode (ByteString -> Maybe Results) -> (ByteString -> ByteString) -> ByteString -> Maybe Results forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString fromStrict (ByteString -> Maybe Results) -> IO ByteString -> IO (Maybe Results) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> CString -> IO ByteString packCString CString s case Maybe Results result of Maybe Results Nothing -> [Char] -> IO () forall a. HasCallStack => [Char] -> a error ([Char] -> IO ()) -> [Char] -> IO () forall a b. (a -> b) -> a -> b $ [Char] "jsaddle message decode failed: " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> Maybe Results -> [Char] forall a. Show a => a -> [Char] show Maybe Results result Just Results r -> Results -> IO () processResult Results r FunPtr (CString -> IO CString) jsaddleSyncResultPtr <- (CString -> IO CString) -> IO (FunPtr (CString -> IO CString)) wrapSyncCallback ((CString -> IO CString) -> IO (FunPtr (CString -> IO CString))) -> (CString -> IO CString) -> IO (FunPtr (CString -> IO CString)) forall a b. (a -> b) -> a -> b $ \CString s -> do Maybe Results result <- ByteString -> Maybe Results forall a. FromJSON a => ByteString -> Maybe a decode (ByteString -> Maybe Results) -> (ByteString -> ByteString) -> ByteString -> Maybe Results forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString fromStrict (ByteString -> Maybe Results) -> IO ByteString -> IO (Maybe Results) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> CString -> IO ByteString packCString CString s case Maybe Results result of Maybe Results Nothing -> [Char] -> IO CString forall a. HasCallStack => [Char] -> a error ([Char] -> IO CString) -> [Char] -> IO CString forall a b. (a -> b) -> a -> b $ [Char] "jsaddle message decode failed: " [Char] -> [Char] -> [Char] forall a. Semigroup a => a -> a -> a <> Maybe Results -> [Char] forall a. Show a => a -> [Char] show Maybe Results result Just Results r -> [Char] -> IO CString newCString ([Char] -> IO CString) -> IO [Char] -> IO CString forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< ByteString -> [Char] unpack (ByteString -> [Char]) -> (Batch -> ByteString) -> Batch -> [Char] forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString toStrict (ByteString -> ByteString) -> (Batch -> ByteString) -> Batch -> ByteString forall b c a. (b -> c) -> (a -> b) -> a -> c . Batch -> ByteString forall a. ToJSON a => a -> ByteString encode (Batch -> [Char]) -> IO Batch -> IO [Char] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Results -> IO Batch processSyncResult Results r CString jsaddleJsPtr <- [Char] -> IO CString newCString ([Char] -> IO CString) -> [Char] -> IO CString forall a b. (a -> b) -> a -> b $ ByteString -> [Char] unpack (ByteString -> [Char]) -> ByteString -> [Char] forall a b. (a -> b) -> a -> b $ ByteString -> ByteString toStrict ByteString jsaddleJs CString jsaddleHtmlPtr <- [Char] -> IO CString newCString ([Char] -> IO CString) -> [Char] -> IO CString forall a b. (a -> b) -> a -> b $ ByteString -> [Char] unpack (ByteString -> [Char]) -> ByteString -> [Char] forall a b. (a -> b) -> a -> b $ ByteString -> ByteString toStrict ByteString indexHtml NativeCallbacks -> IO (Ptr NativeCallbacks) forall a. Storable a => a -> IO (Ptr a) new NativeCallbacks { _nativeCallbacks_jsaddleStart :: FunPtr (IO ()) _nativeCallbacks_jsaddleStart = FunPtr (IO ()) jsaddleStartPtr , _nativeCallbacks_jsaddleResult :: FunPtr (CString -> IO ()) _nativeCallbacks_jsaddleResult = FunPtr (CString -> IO ()) jsaddleResultPtr , _nativeCallbacks_jsaddleSyncResult :: FunPtr (CString -> IO CString) _nativeCallbacks_jsaddleSyncResult = FunPtr (CString -> IO CString) jsaddleSyncResultPtr , _nativeCallbacks_jsaddleJsData :: CString _nativeCallbacks_jsaddleJsData = CString jsaddleJsPtr , _nativeCallbacks_jsaddleHtmlData :: CString _nativeCallbacks_jsaddleHtmlData = CString jsaddleHtmlPtr } data AppConfig = AppConfig { AppConfig -> IO () _appConfig_mainActivityOnCreate :: IO () , AppConfig -> IO () _appConfig_mainActivityOnStart :: IO () , AppConfig -> IO () _appConfig_mainActivityOnResume :: IO () , AppConfig -> IO () _appConfig_mainActivityOnPause :: IO () , AppConfig -> IO () _appConfig_mainActivityOnStop :: IO () , AppConfig -> IO () _appConfig_mainActivityOnDestroy :: IO () , AppConfig -> IO () _appConfig_mainActivityOnRestart :: IO () , AppConfig -> Text -> Text -> IO () _appConfig_mainActivityOnNewIntent :: (Text -> Text -> IO ()) , AppConfig -> Text -> IO () _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO () } instance Default AppConfig where def :: AppConfig def = AppConfig { _appConfig_mainActivityOnCreate :: IO () _appConfig_mainActivityOnCreate = () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnStart :: IO () _appConfig_mainActivityOnStart = () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnResume :: IO () _appConfig_mainActivityOnResume = () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnPause :: IO () _appConfig_mainActivityOnPause = () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnStop :: IO () _appConfig_mainActivityOnStop = () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnDestroy :: IO () _appConfig_mainActivityOnDestroy = () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnRestart :: IO () _appConfig_mainActivityOnRestart = () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnNewIntent :: Text -> Text -> IO () _appConfig_mainActivityOnNewIntent = \Text _ Text _ -> () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO () _appConfig_firebaseInstanceIdServiceSendRegistrationToServer = \Text _ -> () -> IO () forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return () } appConfigToAppCallbacks :: AppConfig -> IO AppCallbacks appConfigToAppCallbacks :: AppConfig -> IO AppCallbacks appConfigToAppCallbacks AppConfig c = do FunPtr (IO ()) create <- IO () -> IO (FunPtr (IO ())) wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ())) forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnCreate AppConfig c FunPtr (IO ()) start <- IO () -> IO (FunPtr (IO ())) wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ())) forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnStart AppConfig c FunPtr (IO ()) resume <- IO () -> IO (FunPtr (IO ())) wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ())) forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnResume AppConfig c FunPtr (IO ()) pause <- IO () -> IO (FunPtr (IO ())) wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ())) forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnPause AppConfig c FunPtr (IO ()) stop <- IO () -> IO (FunPtr (IO ())) wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ())) forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnStop AppConfig c FunPtr (IO ()) destroy <- IO () -> IO (FunPtr (IO ())) wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ())) forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnDestroy AppConfig c FunPtr (IO ()) restart <- IO () -> IO (FunPtr (IO ())) wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ())) forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnRestart AppConfig c FunPtr (CString -> CString -> IO ()) newIntent <- (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ())) wrapMessageCallback2 ((CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ()))) -> (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ())) forall a b. (a -> b) -> a -> b $ \CString intentAction CString intentData -> do Text intentAction' <- CString -> IO Text fromUtf8CString CString intentAction Text intentData' <- CString -> IO Text fromUtf8CString CString intentData AppConfig -> Text -> Text -> IO () _appConfig_mainActivityOnNewIntent AppConfig c Text intentAction' Text intentData' FunPtr (CString -> IO ()) firebaseRegPtr <- (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) wrapMessageCallback ((CString -> IO ()) -> IO (FunPtr (CString -> IO ()))) -> (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) forall a b. (a -> b) -> a -> b $ \CString token -> do Text token' <- CString -> IO Text fromUtf8CString CString token AppConfig -> Text -> IO () _appConfig_firebaseInstanceIdServiceSendRegistrationToServer AppConfig c Text token' AppCallbacks -> IO AppCallbacks forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (AppCallbacks -> IO AppCallbacks) -> AppCallbacks -> IO AppCallbacks forall a b. (a -> b) -> a -> b $ AppCallbacks { _appCallbacks_mainActivity_onCreate :: FunPtr (IO ()) _appCallbacks_mainActivity_onCreate = FunPtr (IO ()) create , _appCallbacks_mainActivity_onStart :: FunPtr (IO ()) _appCallbacks_mainActivity_onStart = FunPtr (IO ()) start , _appCallbacks_mainActivity_onResume :: FunPtr (IO ()) _appCallbacks_mainActivity_onResume = FunPtr (IO ()) resume , _appCallbacks_mainActivity_onPause :: FunPtr (IO ()) _appCallbacks_mainActivity_onPause = FunPtr (IO ()) pause , _appCallbacks_mainActivity_onStop :: FunPtr (IO ()) _appCallbacks_mainActivity_onStop = FunPtr (IO ()) stop , _appCallbacks_mainActivity_onDestroy :: FunPtr (IO ()) _appCallbacks_mainActivity_onDestroy = FunPtr (IO ()) destroy , _appCallbacks_mainActivity_onRestart :: FunPtr (IO ()) _appCallbacks_mainActivity_onRestart = FunPtr (IO ()) restart , _appCallbacks_mainActivity_onNewIntent :: FunPtr (CString -> CString -> IO ()) _appCallbacks_mainActivity_onNewIntent = FunPtr (CString -> CString -> IO ()) newIntent , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer :: FunPtr (CString -> IO ()) _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer = FunPtr (CString -> IO ()) firebaseRegPtr } fromUtf8CString :: CString -> IO Text fromUtf8CString :: CString -> IO Text fromUtf8CString = (ByteString -> Text) -> IO ByteString -> IO Text forall a b. (a -> b) -> IO a -> IO b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ByteString -> Text T.decodeUtf8 (IO ByteString -> IO Text) -> (CString -> IO ByteString) -> CString -> IO Text forall b c a. (b -> c) -> (a -> b) -> a -> c . CString -> IO ByteString packCString pokeAppConfig :: Ptr AppCallbacks -> AppConfig -> IO () pokeAppConfig :: Ptr AppCallbacks -> AppConfig -> IO () pokeAppConfig Ptr AppCallbacks ptr AppConfig cfg = Ptr AppCallbacks -> AppCallbacks -> IO () forall a. Storable a => Ptr a -> a -> IO () poke Ptr AppCallbacks ptr (AppCallbacks -> IO ()) -> IO AppCallbacks -> IO () forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< AppConfig -> IO AppCallbacks appConfigToAppCallbacks AppConfig cfg jsaddleJs :: ByteString jsaddleJs :: ByteString jsaddleJs = ByteString ghcjsHelpers ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> ByteString "\ \runJSaddleBatch = (function() {\n\ \ " ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> ByteString initState ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> ByteString "\n\ \ return function(batch) {\n\ \ " ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString runBatch (\ByteString a -> ByteString "jsaddle.postMessage(JSON.stringify(" ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> ByteString a ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> ByteString "));") ((ByteString -> ByteString) -> Maybe (ByteString -> ByteString) forall a. a -> Maybe a Just (\ByteString a -> ByteString "JSON.parse(jsaddle.syncMessage(JSON.stringify(" ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> ByteString a ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> ByteString ")))")) ByteString -> ByteString -> ByteString forall a. Semigroup a => a -> a -> a <> ByteString "\ \ };\n\ \})();\n\ \jsaddle.postReady();\n" indexHtml :: ByteString indexHtml :: ByteString indexHtml = ByteString "<!DOCTYPE html>\n\ \<html>\n\ \<head>\n\ \<title>JSaddle</title>\n\ \</head>\n\ \<body>\n\ \</body>\n\ \</html>"