javascript-bridge (empty) → 0.2.0
raw patch · 13 files changed
+1273/−0 lines, 13 filesdep +aesondep +basedep +binarysetup-changed
Dependencies added: aeson, base, binary, containers, javascript-bridge, scotty, stm, text, time, transformers, wai, wai-extra, wai-websockets, websockets
Files
- CHANGELOG.md +3/−0
- HISTORY.md +23/−0
- LICENSE +30/−0
- README.md +78/−0
- Setup.hs +2/−0
- examples/Main.hs +30/−0
- examples/Main.html +24/−0
- examples/Multi.hs +112/−0
- javascript-bridge.cabal +78/−0
- src/Network/JavaScript.hs +294/−0
- src/Network/JavaScript/Internal.hs +154/−0
- src/Network/JavaScript/Services.hs +163/−0
- test/Main.hs +282/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## 0.2+* First public release+
+ HISTORY.md view
@@ -0,0 +1,23 @@+javascript-bridge allows Haskell to call JavaScript APIs, and+receive JavaScript events. ++Started Nov 2016 by Andy Gill while at the University of Kansas,+to support calling JavaScript from Haskell, via web sockets,+replacing the comet design pattern based kansas-comet.++ - Reworked in 2018 to+ - support Justin Dawson's Blank Canvas and Remote Monad work+ - direct remote monad / remote applicative support+ - Reworked in 2019 to+ - use finally tagless+ - other improvements and clean up+ +Authors, contributors, or sponsors:+ Andy Gill+ Ryan Scott, Indiana University+ Google Inc.+ - (Andy Gill works at Google, so his contributions to this library during+ his employment comply with Google's open source patching policy)+ This work is supported by the National Science Foundation CAREER #1350901.++Other authors or contributors are welcome!
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016-2019, The University of Kansas++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of The University of Kansas nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,78 @@+# javascript-bridge [](https://travis-ci.org/ku-fpg/javascript-bridge)++**javascript-bridge** is a straightforward way of calling JavaScript+from Haskell, using web-sockets as the underlying transport+mechanism. Conceptually, javascript-bridge gives Haskell acccess to+the JavaScript `eval` function. However, we also support calling and+returning values from JavaScript functions, constructing and using+remote objects, and sending events from JavaScript to Haskell, all+using a remote monad.++# Overview of API++**javascript-bridge** remotely executes JavaScript *fragments*.+The basic Haskell idiom is.+```Haskell+ send eng $ command "console.log('Hello!')"+```+where `send` is an `IO` function that sends a commands for remote execution,+`eng` is a handle into a specific JavaScript engine,+and `command` is a command builder.++There are also ways synchronously sending a `procedure`,+that is a JavaScript expression that constructs a value,+then returns the resulting value.++```Haskell+ do xs :: String <- send eng $ procedure "new Date().toLocaleTimeString()"+ print xs+```++There are ways of creating remote values, for future use,+where Haskell has a handle for this remote value.++```Haskell+data Date = Date -- phantom++ do t :: RemoteValue Date <- send eng $ constructor "new Date()"+ send eng $ procedure $ "console.log(" <> var t <> ".toLocaleTimeString())"+```++Finally, there is a way of sending events from JavaScript,+then listening for the event in Haskell.++```Haskell+ do -- Have JavaScript send an event to Haskell+ send eng $ command $ event ('Hello!'::String)"+ -- Have Haskell wait for the event, which is an Aeson 'Value'.+ e :: Value <- listen eng+ print e+```++# Bootstrapping++Bootstrapping the connection is straightforward.+First, use a `middleware` to setup the (Haskell) server.++```Haskell+import Network.JavaScript++ ...+ scotty 3000 $ do+ middleware $ start app+ ...++app :: Engine -> IO ()+app eng = send eng $ command "console.log('Hello!')"+```++Next, include the following fragment in your HTML code.++```HTML+ <script>+ window.jsb = {ws: new WebSocket('ws://' + location.host)};+ jsb.ws.onmessage = (evt) => eval(evt.data);+ </script>+```++That's it!
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Main.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Web.Scotty+import Network.JavaScript+ +import Paths_javascript_bridge++main :: IO ()+main = main_ 3000++main_ :: Int -> IO ()+main_ i = do+ dataDir <- getDataDir+ -- dataDir <- return "." -- use for debugging+ scotty i $ do+ middleware $ start app + get "/" $ file $ dataDir ++ "/examples/Main.html"++app :: Engine -> IO ()+app eng = do+ send eng $ do+ command $ call "console.log" [string "starting..."]+ render "Hello!"++-- It is good practice to reflect the JavaScript utilties+-- you are using as typed Haskell functions.+render :: Command f => String -> f ()+render t = command $ call "jsb.render" [value t]
+ examples/Main.html view
@@ -0,0 +1,24 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">+ <title>Example</title>+ </head>+ <body>+ <h2>Example</h2>+ <div id="target"></div>+ <script>+ // Bootstrap code+ window.jsb = {ws: new WebSocket('ws://' + location.host)};+ jsb.ws.onmessage = (evt) => eval(evt.data);+ // Debugging to JavaScript console+ jsb.debug = true;+ // Example-specific code+ jsb.render = (t) => {+ document.querySelector('#target').innerHTML += t;+ document.querySelector('#target').innerHTML += '<BR>';+ }+ </script>+ </body>+</html>
+ examples/Multi.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Web.Scotty+import Network.JavaScript+import Data.Semigroup+import Text.Read(readMaybe)+ +import Paths_javascript_bridge++main :: IO ()+main = main_ 3000++data Applets+ = Commands+ | Procedures+ | Constructors+ | Promises+ deriving (Eq, Ord, Show, Read, Enum, Bounded)+++main_ :: Int -> IO ()+main_ i = do+ dataDir <- getDataDir+ --dataDir <- return "." -- use for debugging+ scotty i $ do+ middleware $ start app+ -- Any path, including /, returns the contents of Main.hs+ get "/:cmd" $ file $ dataDir ++ "/examples/Main.html"++app :: Engine -> IO ()+app eng = do+ -- simple dispatch based on location+ hash <- send eng $ procedure "window.location.pathname"+ case hash of+ "/" -> indexPage eng+ '/':xs -> case readMaybe xs of+ Just sub -> applet eng sub+ Nothing -> return ()+ _ -> return ()++indexPage :: Engine -> IO ()+indexPage eng = send eng $ render $+ "<ol>" <> Prelude.concat+ ["<li><a href=\"/" <> show a <> "\">"+ <> show a+ <> "</a></li>"+ | a <- [minBound .. maxBound] :: [Applets]+ ] <>+ "</ol>"++applet :: Engine -> Applets -> IO ()+applet eng Commands = do+ send eng $ do+ render "Hello World!"+applet eng Procedures = do+ send eng $ do+ -- The addition is done using JavaScript+ n <- addition 1.0 2.0+ render $ "1.0 + 2.0 = " ++ show n+applet eng Constructors = do+ send eng $ do+ -- Here, we construct an object, and it remotely+ o <- constructor "{n : 1}"+ n :: Int <- procedure $ var o <> ".n"+ render $ show n+ command $ var o <> ".n++"+ n :: Int <- procedure $ var o <> ".n"+ render $ show n+applet eng Promises = do+ send eng $ do+ -- When a promise is returned by a procedure,+ -- then we wait for it to resolve.+ p1 <- procedure $+ "new Promise((resolve,reject) => {" <>+ " setTimeout(() => { resolve('Done p1')}, 1000)" <>+ "})"+ render $ show (p1 :: String)+ send eng $ do+ -- When we group return values, we wait for all+ -- promises to resolve before returning to Haskell.+ -- Internally, this uses Promises.all()+ (p2,p3) <- (,) <$>+ (procedure $+ "new Promise((resolve,reject) => {" <>+ " setTimeout(() => { resolve('Done p2')}, 1000)" <>+ "})") <*>+ (procedure $+ "new Promise((resolve,reject) => {" <>+ " setTimeout(() => { resolve('Done p3')}, 500)" <>+ "})")+ render $ show (p2 :: String, p3 :: String)+ send eng $ do+ -- constructors create remote handles, and the+ -- handle can be a promise, and is returned+ -- immeduately.+ p2 <- constructor $+ "new Promise((resolve,reject) => {" <>+ " setTimeout(() => { resolve('Done p4')}, 1000)" <>+ "})"+ command $ var p2 <> ".then((v) => { jsb.render(JSON.stringify(v)) })"++ +-- It is good practice to reflect the JavaScript utilties+-- you are using as typed Haskell functions.+render :: Command f => String -> f ()+render t = command $ call "jsb.render" [value t]++addition :: Procedure f => Double -> Double -> f Double+addition a b = procedure $ value a <> "+" <> value b
+ javascript-bridge.cabal view
@@ -0,0 +1,78 @@+name: javascript-bridge+version: 0.2.0+synopsis: Remote Monad for JavaScript on the browser+description: Bridge from Haskell to JavaScript on the browser+license: BSD3+license-file: LICENSE+author: Andy Gill+maintainer: andygill@ku.edu+copyright: Copyright (c) 2016-2019 The University of Kansas+category: Network+build-type: Simple+extra-source-files: CHANGELOG.md, README.md, HISTORY.md+cabal-version: >=1.10+tested-with: GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.1++data-files:+ examples/Main.html+ +source-repository head+ type: git+ location: https://github.com/ku-fpg/javascript-bridge++library+ exposed-modules: Network.JavaScript,+ Network.JavaScript.Internal,+ Network.JavaScript.Services+ build-depends: base >= 4.9 && < 4.14+ , binary >= 0.8 && < 0.9+ , aeson >= 1.4 && < 1.5+ , containers >= 0.5 && < 0.7+ , stm >= 2.4 && < 2.6+ , text >= 1.2 && < 1.3+ , time >= 1.6 && < 1.10 + , transformers >= 0.4 && < 0.6+ , wai >= 3.2 && < 3.3+ , wai-websockets >= 3.0.1 && < 3.1+ , websockets >= 0.10 && < 0.13+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++test-suite javascript-bridge-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-depends: base >= 4.9 && < 4.14+ , aeson >= 1.0 && < 1.5+ , javascript-bridge+ , scotty == 0.11.*+ , wai-extra == 3.0.*+ , stm >= 2.4 && < 2.6+ , text >= 1.2 && < 1.3+ , time >= 1.6 && < 1.10+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: -threaded -Wall++executable javascript-bridge-simple+ main-is: Main.hs+ other-modules: Paths_javascript_bridge+ build-depends: base >= 4.9 && < 4.14+ , javascript-bridge+ , scotty == 0.11.*+ hs-source-dirs: examples+ default-language: Haskell2010+ ghc-options: -threaded -Wall++executable javascript-bridge-examples+ main-is: Multi.hs+ other-modules: Paths_javascript_bridge+ build-depends: base >= 4.9 && < 4.14+ , javascript-bridge+ , scotty == 0.11.*+ , text >= 1.2 && < 1.3+ hs-source-dirs: examples+ default-language: Haskell2010+ ghc-options: -threaded -Wall
+ src/Network/JavaScript.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE OverloadedStrings,KindSignatures, GADTs, ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ConstraintKinds #-}++module Network.JavaScript+ ( -- * Sending Remote Monads and Packets+ send+ , sendA+ , sendE+ -- * Building Remote Monads and Packets+ , JavaScript(..)+ , command+ , procedure+ , constructor+ -- * Remote Applicative and Monads, and classes for building them+ , Packet+ , RemoteMonad+ , Command()+ , Procedure()+ -- * Remote Values+ , RemoteValue+ , delete+ , localize+ , remote+ -- * JavaScript builders+ , var+ , value+ , call+ , number+ , string+ -- * Events+ , JavaScriptException(..)+ , event+ , addListener+ , listen+ , readEventChan+ -- * Web services+ , start+ , Engine+ , Application+ ) where++import Control.Applicative(liftA2)+import Control.Exception(Exception, throwIO)+import Data.Monoid ((<>))+import qualified Data.Text.Lazy as LT+import Data.Text.Lazy (Text)+import Network.Wai (Application)+import Control.Monad.Trans.State.Strict++import Data.Aeson ( Value(..), FromJSON(..), ToJSON(..), encode, Result(..), fromJSON)+import Data.Text.Lazy.Encoding(decodeUtf8)+++import Network.JavaScript.Internal+import Network.JavaScript.Services++------------------------------------------------------------------------------++-- | 'command' statement to execute in JavaScript. ';' is not needed as a terminator.+-- Should never throw an exception, which may be reported to console.log.+command :: Command f => JavaScript -> f ()+command = internalCommand+ +-- | 'constructor' expression to execute in JavaScript. ';' is not needed as a terminator.+-- Should never throw an exception, but any exceptions are returned to the 'send'+-- as Haskell exceptions.+--+-- The value returned in not returned to Haskell. Instead, a handle is returned,+-- that can be used to access the remote value. Examples of remote values include+-- objects that can not be serialized, or values that are too large to serialize.+--+-- The first type argument is the phantom type of the 'RemoteValue', so that+-- type application can be used to specify the type.+constructor :: forall a f . Command f => JavaScript -> f (RemoteValue a)+constructor = internalConstructor++-- | 'procedure' expression to execute in JavaScript. ';' is not needed as a terminator.+-- Should never throw an exception, but any exceptions are returned to the 'send'+-- as Haskell exceptions.+--+-- Procedures can return Promises. Before completing the transaction, all the values+-- for all the procedures that are promises are fulfilled (using Promises.all).+--+-- If a procedure throws an exception, future commands and procedures in+-- the same packet will not be executed. Use promises to allow all commands and+-- procedures to be invoked, if needed.+procedure :: forall a f . (Procedure f, FromJSON a) => JavaScript -> f a+procedure = internalProcedure++------------------------------------------------------------------------------++-- | 'send' a remote monad for execution on a JavaScript engine.+-- The monad may be split into several packets for transmission+-- and exection.++send :: Engine -> RemoteMonad a -> IO a+send e p = do+ r <- sendE e p+ case r of+ Right a -> return a+ Left err -> throwIO $ JavaScriptException err++data JavaScriptException = JavaScriptException Value+ deriving (Show,Eq)++instance Exception JavaScriptException++-- | 'send' with all JavaScript exceptions caught and returned.+sendE :: Engine -> RemoteMonad a -> IO (Either Value a)+sendE e (RemoteMonad rm) = go rm+ where+ go m = do+ w <- walkStmtM e m+ case w of+ ResultPacket af _ -> sendStmtA e af+ IntermPacket af k -> do+ r <- sendStmtA e af+ case r of+ Right a -> go (k a)+ Left msg -> return $ Left msg++data PingPong a where+ ResultPacket :: AF Stmt a -> Maybe a -> PingPong a+ IntermPacket :: AF Stmt a -> (a -> M Primitive b) -> PingPong b++walkStmtM :: Engine -> M Primitive a -> IO (PingPong a)+walkStmtM _ (PureM a) = pure $ ResultPacket (pure a) (pure a)+walkStmtM Engine{..} (PrimM p) = do+ s <- prepareStmt genNonce p+ let af = PrimAF s+ return $ ResultPacket af (evalStmtA af [])+walkStmtM e (ApM g h) = do+ w1 <- walkStmtM e g+ case w1 of+ ResultPacket g_af g_r -> do+ w2 <- walkStmtM e h+ case w2 of+ ResultPacket h_af h_r -> return $ ResultPacket (g_af <*> h_af) (liftA2 ($) g_r h_r)+ IntermPacket h_af k -> return $+ IntermPacket (liftA2 (,) g_af h_af)+ (\ (r1,r2) -> pure r1 <*> k r2)+ IntermPacket g_af k -> return $ IntermPacket g_af (\ r -> k r <*> h)+walkStmtM e (BindM m k) = do+ w1 <- walkStmtM e m+ case w1 of+ ResultPacket m_af (Just a) -> do+ w2 <- walkStmtM e (k a)+ case w2 of+ ResultPacket h_af h_r ->+ return $ ResultPacket (m_af *> h_af) h_r+ IntermPacket h_af k' -> return $+ IntermPacket (m_af *> h_af) k'+ ResultPacket m_af Nothing ->+ return $ IntermPacket m_af k+ IntermPacket m_af k0 -> return $ IntermPacket m_af (\ r -> k0 r >>= k)++-- | send an (applicative) 'Packet'. This packet always sent atomically to JavaScript.+sendA :: Engine -> Packet a -> IO a+sendA e p = do+ r <- sendAE e p+ case r of+ Right a -> return a+ Left err -> throwIO $ JavaScriptException err++-- INLINE+sendAE :: Engine -> Packet a -> IO (Either Value a)+sendAE e@Engine{..} (Packet af) = prepareStmtA genNonce af >>= sendStmtA e++-- statements are internal single JavaScript statements, that can be+-- transliterated trivially into JavaScript, or interpreted to give+-- a remote effect, including result.++data Stmt a where+ CommandStmt :: JavaScript -> Stmt ()+ ProcedureStmt :: FromJSON a => Int -> JavaScript -> Stmt a+ ConstructorStmt :: RemoteValue a -> JavaScript -> Stmt (RemoteValue a)++deriving instance Show (Stmt a)+ +prepareStmtA :: Monad f => f Int -> AF Primitive a -> f (AF Stmt a)+prepareStmtA _ (PureAF a) = pure (pure a)+prepareStmtA ug (PrimAF p) = PrimAF <$> prepareStmt ug p+prepareStmtA ug (ApAF g h) = ApAF <$> prepareStmtA ug g <*> prepareStmtA ug h++prepareStmt :: Monad f => f Int -> Primitive a -> f (Stmt a)+prepareStmt _ (Command stmt) = pure $ CommandStmt stmt+prepareStmt ug (Procedure stmt) = ug >>= \ i -> pure $ ProcedureStmt i stmt+prepareStmt ug (Constructor stmt) = ug >>= \ i -> pure $ ConstructorStmt (RemoteValue i) stmt+ +showStmtA :: AF Stmt a -> JavaScript+showStmtA stmts = JavaScript+ $ LT.concat [ js | JavaScript js <- concatAF (return . showStmt) stmts ]++showStmt :: Stmt a -> JavaScript+showStmt (CommandStmt cmd) = cmd <> ";"+showStmt (ProcedureStmt n cmd) = "var " <> procVar n <> "=" <> cmd <> ";"+showStmt (ConstructorStmt rv cmd) = var rv <> "=" <> cmd <> ";"++evalStmtA :: AF Stmt a -> [Value] -> Maybe a+evalStmtA af st = evalStateT (evalAF evalStmt af) st++evalStmt :: Stmt a -> StateT [Value] Maybe a+evalStmt (CommandStmt _) = pure ()+evalStmt (ProcedureStmt _ _) = do+ vs <- get+ case vs of+ (v:vs') -> put vs' >> case fromJSON v of+ Error _ -> fail "can not parse result"+ Success r -> return r+ _ -> fail "not enough values"+evalStmt (ConstructorStmt c _) = pure c++sendStmtA :: Engine -> AF Stmt a -> IO (Either Value a)+sendStmtA _ (PureAF a) = return (pure a)+sendStmtA e af+ | null assignments = do+ sendJavaScript e $ showStmtA af+ return $ case evalStmtA af [] of+ Nothing -> error "internal failure"+ Just r -> Right r + | otherwise = do+ nonce <- genNonce e+ sendJavaScript e $ catchMe nonce $ showStmtA af+ theReply <- replyBox e nonce+ case theReply of+ Right replies -> return $ case evalStmtA af replies of+ Nothing -> error "internal failure"+ Just r -> Right r+ Left err -> return $ Left err+ + where+ catchMe :: Int -> JavaScript -> JavaScript+ catchMe nonce txt =+ "try{" <> txt+ <> "}catch(err){jsb.error(" <> JavaScript (LT.pack (show nonce))+ <> ",err);};" <>+ reply nonce <> ";"++ assignments :: [Int]+ assignments = concatAF findAssign af++ findAssign :: Stmt a -> Maybe Int+ findAssign (ProcedureStmt i _) = Just i+ findAssign _ = Nothing+ + -- generate the call to reply (as a final command)+ reply :: Int -> JavaScript+ reply n = JavaScript $+ "jsb.reply(" <> LT.intercalate ","+ [ LT.pack (show n)+ , "[" <> LT.intercalate "," [ x | JavaScript x <- map procVar assignments] <> "]"+ ] <> ")"++-- TODO: Consider a wrapper around this Int+procVar :: Int -> JavaScript+procVar n = JavaScript $ "v" <> LT.pack (show n)++------------------------------------------------------------------------------++-- | 'delete' a remote value.+delete :: Command f => RemoteValue a -> f ()+delete rv = command $ "delete " <> var rv++-- | 'localize' brings a remote value into Haskell.+localize :: Procedure f => RemoteValue a -> f Value+localize = procedure . var++-- | 'remote' sends a local value to JavaScript.+remote :: Command f => Value -> f (RemoteValue a)+remote = constructor . value++-- | Generate a 'JavaScript' value, including for 'RemoteValue''s.+value :: ToJSON v => v -> JavaScript+value = JavaScript . decodeUtf8 . encode++-- | Generate JavaScript number+number :: Double -> JavaScript+number = value++-- | Generate (quoted) JavaScript string+string :: Text -> JavaScript+string = value++-- | Generate a function call+call :: JavaScript -> [JavaScript] -> JavaScript+call fn args = fn <> "(" <> JavaScript (LT.intercalate "," [ js | JavaScript js <- args ]) <> ")"++-- | Send an event back to Haskell+event :: ToJSON v => v -> JavaScript+event v = call "jsb.event" [value v]
+ src/Network/JavaScript/Internal.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE OverloadedStrings,KindSignatures, GADTs, ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ConstraintKinds #-}++module Network.JavaScript.Internal+ ( -- * JavaScript+ JavaScript(..)+ -- * Commands+ , Command()+ , internalCommand+ , internalConstructor+ -- * Procedures+ , Procedure()+ , internalProcedure+ -- * Primitives and (Remote) Values+ , Primitive(..)+ , RemoteValue(..)+ , var+ -- * (Applicative) Packets+ , Packet(..)+ , AF(..)+ , RemoteMonad(..)+ , evalAF+ , concatAF+ -- * Monads+ , M(..)+ , evalM+ ) where++import Data.Aeson (ToJSON(..), FromJSON(..))+import qualified Data.Aeson.Encoding.Internal as AI+import qualified Data.Binary.Builder as B+import Data.Text.Lazy(Text, pack)+import Data.Text.Lazy.Encoding(encodeUtf8)+import Data.String++------------------------------------------------------------------------------++newtype JavaScript = JavaScript Text+ deriving Show++instance IsString JavaScript where+ fromString = JavaScript . fromString+ +instance Semigroup JavaScript where+ JavaScript x <> JavaScript y = JavaScript $ x <> y+ +instance Monoid JavaScript where+ mempty = JavaScript mempty+ mappend = (<>)++class Command f where+ internalCommand :: JavaScript -> f ()+ internalConstructor :: JavaScript -> f (RemoteValue a)++class Procedure f where+ internalProcedure :: FromJSON a => JavaScript -> f a+ +-- | The Remote Applicative Packet+newtype Packet a = Packet (AF Primitive a)+ deriving (Functor, Applicative)++-- | The Remote Monad+newtype RemoteMonad a = RemoteMonad (M Primitive a)+ deriving (Functor, Applicative, Monad)++data Primitive :: * -> * where+ Command :: JavaScript -> Primitive ()+ Procedure :: FromJSON a => JavaScript -> Primitive a+ Constructor :: JavaScript -> Primitive (RemoteValue a)++instance Command Packet where+ internalCommand = Packet . PrimAF . Command + internalConstructor = Packet . PrimAF . Constructor++instance Procedure Packet where+ internalProcedure = Packet . PrimAF . Procedure++instance Command RemoteMonad where+ internalCommand = RemoteMonad . PrimM . Command + internalConstructor = RemoteMonad . PrimM . Constructor++instance Procedure RemoteMonad where+ internalProcedure = RemoteMonad . PrimM . Procedure++-- A Local handle into a remote value.+newtype RemoteValue a = RemoteValue Int+ deriving (Eq, Ord, Show)++-- Remote values can not be encoded in JSON, but are JavaScript variables.+instance ToJSON (RemoteValue a) where+ toJSON = error "toJSON not supported for RemoteValue"+ toEncoding rv = AI.unsafeToEncoding $ B.fromLazyByteString $ encodeUtf8 txt+ where+ JavaScript txt = var rv+ +-- | generate the text for a RemoteValue. They can be used as assignment+-- targets as well, but exposes the JavaScript scoping semantics.+var :: RemoteValue a -> JavaScript+var (RemoteValue n) = JavaScript $ "jsb.rs[" <> pack (show n) <> "]"++------------------------------------------------------------------------------+-- Framework types for Applicative and Monad++data AF :: (* -> *) -> * -> * where+ PureAF :: a -> AF m a+ PrimAF :: m a -> AF m a+ ApAF :: AF m (a -> b) -> AF m a -> AF m b++instance Functor (AF m) where+ fmap f g = pure f <*> g+ +instance Applicative (AF m) where+ pure = PureAF+ (<*>) = ApAF++concatAF :: (forall x . m x -> Maybe b) -> AF m a -> [b]+concatAF _ (PureAF _) = []+concatAF f (PrimAF p) = case f p of+ Nothing -> []+ Just r -> [r]+concatAF f (ApAF m1 m2) = concatAF f m1 ++ concatAF f m2++evalAF :: Applicative f => (forall x . m x -> f x) -> AF m a -> f a+evalAF _ (PureAF a) = pure a+evalAF f (PrimAF p) = f p+evalAF f (ApAF g h) = evalAF f g <*> evalAF f h++data M :: (* -> *) -> * -> * where+ PureM :: a -> M m a+ PrimM :: m a -> M m a+ ApM :: M m (a -> b) -> M m a -> M m b+ BindM :: M m a -> (a -> M m b) -> M m b++instance Functor (M m) where+ fmap f g = pure f <*> g+ +instance Applicative (M m) where+ pure = PureM+ (<*>) = ApM++instance Monad (M m) where+ return = PureM+ (>>=) = BindM+ (>>) = (*>)++evalM :: Monad f => (forall x . m x -> f x) -> M m a -> f a+evalM _ (PureM a) = pure a+evalM f (PrimM p) = f p+evalM f (ApM g h) = evalM f g <*> evalM f h+evalM f (BindM m k) = evalM f m >>= evalM f . k
+ src/Network/JavaScript/Services.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings,KindSignatures, GADTs, ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+module Network.JavaScript.Services+ ( -- * Web Services+ Engine(..)+ , start+ , addListener+ , listen+ , readEventChan+ , Application+ ) where++import Control.Applicative((<|>))+import qualified Data.Text.Lazy as LT+import Data.Time.Clock+import qualified Network.Wai.Handler.WebSockets as WS+import Network.Wai (Application)+import qualified Network.WebSockets as WS++import Control.Concurrent (forkIO, ThreadId)+import Control.Exception (try, SomeException)+import Control.Monad (forever)+import Control.Concurrent.STM+import Data.Aeson (Value(..), decode', FromJSON(..),withObject,(.:))+import qualified Data.IntMap.Strict as IM++import Network.JavaScript.Internal(JavaScript(..))++-- | This accepts WebSocket requests, calls the callback with+-- an 'Engine' that can be used to access JavaScript.++start :: (Engine -> IO ())+ -> Application -> Application+start kE = WS.websocketsOr WS.defaultConnectionOptions $ \ pc -> do+ conn <- WS.acceptRequest pc+ -- Use ping to keep connection alive+ WS.forkPingThread conn 10+ -- Bootstrap the remote handler+ WS.sendTextData conn bootstrap+ -- Handling packets+ nonceRef <- newTVarIO 0+ replyMap <- newTVarIO IM.empty+ eventQueue <- newTChanIO+ + let catchMe m = try m >>= \ (_ :: Either SomeException ()) -> return ()+ _ <- forkIO $ catchMe $ forever $ do+ d <- WS.receiveData conn+ case decode' d of+ Just (Result _ []) -> return ()+ Just (Result n replies) -> atomically+ $ modifyTVar replyMap+ $ IM.insert n+ $ Right+ $ replies+ Just (Error n obj) -> atomically+ $ modifyTVar replyMap+ $ IM.insert n+ $ Left+ $ obj+ Just (Event event) -> do+ utc <- getCurrentTime+ atomically $ writeTChan eventQueue (event,utc)+ + Nothing -> print ("bad (non JSON) reply from JavaScript"::String,d)++ kE $ Engine+ { sendJavaScript = \ (JavaScript js) -> WS.sendTextData conn js+ , genNonce = atomically $ do+ n <- readTVar nonceRef+ writeTVar nonceRef $ succ n+ return n+ , replyBox = \ n -> atomically $ do+ t <- readTVar replyMap+ case IM.lookup n t of+ Nothing -> retry+ Just v -> return v+ , eventChan = readTChan eventQueue+ }++-- | An 'Engine' is a handle to a specific JavaScript engine+data Engine = Engine+ { sendJavaScript :: JavaScript -> IO () -- send text to the JS engine+ , genNonce :: IO Int -- nonce generator+ , replyBox :: Int -> IO (Either Value [Value]) -- reply mailbox+ , eventChan :: STM (Value, UTCTime)+ }++bootstrap :: LT.Text+bootstrap = LT.unlines+ [ "jsb.event = function(ev) {"+ , " if (jsb.debug) { console.log('event',{event: ev}); }"+ , " jsb.ws.send(JSON.stringify({event: ev}));"+ , " };"+ , "jsb.error = function(n,err) {"+ , " if (jsb.debug) { console.log('send',{id: n, error: err}); }"+ , " jsb.ws.send(JSON.stringify({id: n, error: err}));"+ , " throw(err);"+ , " };" + , "jsb.reply = function(n,obj) {"+ , " Promise.all(obj).then(function(obj){"+ , " if (jsb.debug) { console.log('reply',{id:n, result:obj}); }" + , " jsb.ws.send(JSON.stringify({id: n, result: obj}));"+ , " }).catch(function(err){"+ , " jsb.error(n,err);"+ , " });"+ , " };"+ , "jsb.ws.onmessage = function(evt){ "+ , " if (jsb.debug) { console.log('eval',evt.data); }"+ , " eval('(function(){' + evt.data + '})()');"+ , "};"+ , "jsb.rs = [];"+ ]++--+-- | Add a listener for events. There can be many. non-blocking.+--+-- From JavaScript, you can call event(..) to send+-- values to this listener. Any valid JSON value can be sent.+addListener :: Engine -> (Value -> IO ()) -> IO ThreadId+addListener e k = forkIO $ forever $ listen e >>= k++-- | 'listen' for the next event. blocking.+--+-- From JavaScript, you can call event(..) to send+-- values to this listener. Any valid JSON value can be sent.+--+--+listen :: Engine -> IO Value+listen e = atomically $ fst <$> readEventChan e++-- | 'readEventChan' uses STM to read the next event.+--+-- From JavaScript, you can call event(..) to send+-- values to this channel. Any valid JSON value can be sent.+--+--+readEventChan :: Engine -> STM (Value, UTCTime)+readEventChan = eventChan++------------------------------------------------------------------------------++-- This is what we send back from JavaScript.+data Reply = Result Int [Value]+ | Error Int Value+ | Event Value+ deriving Show++instance FromJSON Reply where+ parseJSON o = parseEvent o+ <|> parseResult o+ <|> parseError o+ where+ parseEvent = withObject "Event" $ \v -> Event+ <$> v .: "event"+ parseResult = withObject "Result" $ \v -> Result+ <$> v .: "id"+ <*> v .: "result"+ parseError = withObject "Error" $ \v -> Error+ <$> v .: "id"+ <*> v .: "error"+
+ test/Main.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GADTs #-}+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import qualified Control.Exception as E+import Control.Monad (forever, foldM, void)+import Data.Aeson+import Data.Monoid((<>))+import qualified Data.Text.Lazy as T+import Network.JavaScript as JS+import Network.Wai.Middleware.RequestLogger+import System.Exit+import Web.Scotty hiding (delete, function)+import Data.Time.Clock++main = main_ 3000++main_ :: Int -> IO ()+main_ i = do+ lock <- newEmptyMVar++ void $ forkIO $ scotty i $ do+-- middleware $ logStdout+ + middleware $ start $ \ e -> example e `E.finally`+ (do putMVar lock ()+ putStrLn "Finished example")+++ get "/" $ do+ html $ mconcat $+ [+ "<!doctype html>"+ , "<html lang=\"en\">"+ , "<head>"+ , "<!-- Required meta tags -->"+ , "<meta charset=\"utf-8\">"+ , "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1, shrink-to-fit=no\">"+ , "<!-- Bootstrap CSS -->"+ , "<link rel=\"stylesheet\" href=\"https://stackpath.bootstrapcdn.com/bootstrap/4.1.3/css/bootstrap.min.css\" integrity=\"sha384-MCw98/SFnGE8fJT3GXwEOngsV7Zt27NXFoaoApmYm81iuXoPkFOJwJ8ERdknLPMO\" crossorigin=\"anonymous\">"++ , "<title>JavaScript Bridge Tests</title>"+ , "</head>"+ , "<body>"+ , " <div class=\"container\">"+ , "<h3>JavaScript Bridge Tests</h3>"+ , " <div class=\"row\">"+ , " <div class=\"col-3\"><p class=\"font-weight-bold\">Groups</p></div>"+ , " <div class=\"col-5\"><p class=\"font-weight-bold\">Tests</p></div>"+ , " <div class=\"col-2\"><p class=\"text-center font-weight-bold\">Applicative</p></div>"+ , " <div class=\"col-2\"><p class=\"text-center font-weight-bold\">Monad</p></div>"+ , " </div>"+ , T.pack (table tests)+ , "</div>"+ , "<script>"+ , "window.jsb = {ws: new WebSocket('ws://' + location.host)};"+ , "jsb.ws.onmessage = (evt) => eval(evt.data);"+ -- remote object to allow interesting commands and procedures+ , "var remote = [];"+ , "var stepme = function(dom,s) {"+ , " var start = null;"+ , " function step(timestamp) {"+ , " if (!start) start = timestamp;"+ , " if (dom.classList.contains('bg-success') || dom.classList.contains('bg-danger')) return;"+ , " var progress = parseInt((timestamp - start) * 100 / (1000 * s));"+ , " dom.style.width='' + progress + '%';"+ , " dom.innerHTML='' + progress + '%';"+ , " if (progress < 100) {"+ , " window.requestAnimationFrame(step);"+ , " } else {" + , " dom.classList.add('bg-danger');"+ , " }"+ , " }"+ , " requestAnimationFrame(step);"+ , "};"+ , "</script>"+ , "</body>"+ , "</html>"+ ]++ takeMVar lock++data Test+ = TestA String (forall f . (Command f, Procedure f, Applicative f) => API f -> IO (Maybe String))+ | TestM String (forall f . (Command f, Procedure f, Monad f) => API f -> IO (Maybe String))++data Tests = Tests String [Test]++data API f = API+ { send :: forall a . f a -> IO a+ , recv :: IO (Result Value)+ , progressBar :: RemoteValue DOM+ }++data DOM++------------------------------------------------------------------------------++tests :: [Tests]+tests =+ [ Tests "Commands"+ [ TestA "command" $ \ API{..} -> send (command "1") >> pure Nothing+ ]+ , Tests "Procedures"+ [ TestA "procedure 1 + 1" $ \ API{..} -> do+ v :: Int <- send (procedure "1+1")+ assert v (2 :: Int)+ , TestA "procedure 'Hello'" $ \ API{..} -> do+ v :: String <- send (procedure "'Hello'")+ assert v ("Hello" :: String)+ , TestA "procedure [true,false]" $ \ API{..} -> do+ v :: [Bool] <- send (procedure "[true,false]")+ assert v [True,False]+ ]+ , Tests "Combine Commands / Procedure"+ [ TestA "command [] + push" $ \ API{..} -> do+ send (command "local = []" *> command "local.push(99)") + v :: [Int] <- send (procedure "local")+ assert v [99]+ , TestA "command [] + push + procedure" $ \ API{..} -> do+ v :: [Int] <- send (command "local = []" *> command "local.push(99)" *> procedure "local")+ assert v [99]+ , TestA "procedure + procedure" $ \ API{..} -> do+ v :: (Int,Bool) <- send (liftA2 (,)+ (procedure "99")+ (procedure "false"))+ assert v (99,False)+ ] + , Tests "Promises"+ [ TestA "promises" $ \ API{..} -> do+ v :: (String,String) <- send $ liftA2 (,)+ (procedure "new Promise(function(good,bad) { good('Hello') })")+ (procedure "new Promise(function(good,bad) { good('World') })")+ assert v ("Hello","World")+ , TestA "promise + procedure" $ \ API{..} -> do+ v :: (String,String) <- send $ liftA2 (,)+ (procedure "new Promise(function(good,bad) { good('Hello') })")+ (procedure "'World'")+ assert v ("Hello","World")+ , TestA "good and bad promises" $ \ API{..} -> do+ v :: Either JavaScriptException ((String,String,String)) <- E.try $ send $ liftA3 (,,)+ (procedure "new Promise(function(good,bad) { good('Hello') })")+ (procedure "new Promise(function(good,bad) { bad('Promise Reject') })")+ (procedure "new Promise(function(good,bad) { good('News') })")+ assert v (Left $ JavaScriptException $ String "Promise Reject") + ]+ , Tests "Constructors"+ [ TestA "constructor" $ \ API{..} -> do+ rv :: RemoteValue () <- send $ constructor "'Hello'"+ v1 :: String <- send $ procedure (var rv)+ send $ delete rv + v2 :: Value <- send $ procedure (var rv)+ assert (v1,v2) ("Hello",Null)+ ]+ , Tests "Exceptions"+ [ TestA "command throw" $ \ API{..} -> do+ send $ command $ "throw 'Command Fail';"+ assert () ()+ , TestA "procedure throw" $ \ API{..} -> do+ v :: Either JavaScriptException Value <- E.try $ send $ procedure $ "(function(){throw 'Command Fail';})()"+ assert v (Left $ JavaScriptException $ String "Command Fail")+ ]+ , Tests "Events"+ [ TestA "event" $ \ API{..} -> do+ send $ command $ event ("Hello, World" :: String)+ event <- recv+ assert event (Success $ toJSON ("Hello, World" :: String))+ ]+ , Tests "Remote Monad"+ [ TestM "remote monad procedure chain" $ \ API{..} -> do+ vs :: Value <- + (send $ foldM (\ (r :: Value) (i :: Int) -> procedure $ value r <> "+" <> value i)+ (toJSON (0 :: Int))+ [0..100])+ assert vs (toJSON $ sum [0..100::Int])+ , TestM "remote monad constructor chain" $ \ API{..} -> do+ rv <- send $ constructor "0"+ rv :: RemoteValue () <- + (send $ foldM (\ (r :: RemoteValue ()) (i :: Int) -> constructor $ value r <> "+" <> value i)+ rv+ [0..100])+ v :: Int <- (send $ procedure $ value rv)+ assert v (sum [0..100])+ ]+ , Tests "Alive Connection" $+ [ TestM "before wait" $ \ API{..} -> do+ assert () ()+ ] ++ [ TestM ("after wait for " ++ show w) $ \ API{..} -> do+ send $ command $ "stepme(" <> var progressBar <> "," <> value (fromIntegral w * 1.2 :: Float) <> ")"+ _ <- threadDelay $ w * 1000 * 1000+ assert () ()+ | w <- [3,10,80]+ ]+ ]++------------------------------------------------------------------------------++assert :: (Eq a, Show a) => a -> a -> IO (Maybe String)+assert n g+ | n == g = return $ Nothing+ | otherwise = return $ Just $ show ("assert failure",n,g)++table :: [Tests] -> String+table ts = go0 [] ts + where+ go0 p ts = concatMap (\ (t,n) -> go1 (n:p) t) (zip ts [0..])++ go1 p (Tests txt ts) = unlines+ [ "<div class=\"row\">" +++ "<div class=\"col-3\">" +++ pre +++ "</div>" +++ "<div class=\"col-5\">" +++ tst +++ "</div>" +++ "<div class=\"col-2\">" +++ mon +++ "</div>" +++ "<div class=\"col-2\">" +++ app +++ "</div>" ++ + "</div>"+ | (t,n) <- ts `zip` [0..]+ , let pre | n == 0 = txt+ | otherwise = ""+ , let (tst,mon,app) = go (n:p) t+ ]++ go p (TestA txt _) = (txt,bar p "a",bar p "m")+ go p (TestM txt _) = (txt,"",bar p "m")++ bar p a = "<div class=\"progress\"><div id=\"" ++ tag p ++ "-" ++ a ++ "\" class=\"progress-bar\" role=\"progressbar\" style=\"width: 0%;\"></div></div>"++tag :: [Int] -> String+tag p = "tag" ++ concatMap (\ a -> '-' : show a) p++runTest :: Engine -> [Int] -> Test -> IO ()+runTest e p (TestA txt k) = do+ recv <- doRecv e+ mBar <- JS.send e $ constructor $ JavaScript $ "document.getElementById('" <> T.pack (tag p ++ "-m") <> "')"+ aBar <- JS.send e $ constructor $ JavaScript $ "document.getElementById('" <> T.pack (tag p ++ "-a") <> "')"+ doTest (API (JS.send e) recv mBar) "-m" p k+ doTest (API (JS.sendA e) recv aBar) "-a" p k+runTest e p (TestM txt k) = do+ recv <- doRecv e+ mBar <- JS.send e $ constructor $ JavaScript $ "document.getElementById('" <> T.pack (tag p ++ "-m") <> "')"+ doTest (API (JS.send e) recv mBar) "-m" p k++doRecv :: Engine -> IO (IO (Result Value))+doRecv e = do+ return $ do+ wait <- registerDelay $ 1000 * 1000+ atomically $ (pure . fst <$> readEventChan e)+ `orElse` (do b <- readTVar wait ; check b ; return $ Error "timeout!") ++doTest :: (Applicative f, Command f) => API f -> String -> [Int] -> (API f -> IO (Maybe String)) -> IO ()+doTest api@API{..} suff p k = do+ tm0 <- getCurrentTime+ rM <- k api+ tm1 <- getCurrentTime+ let tm = show (diffUTCTime tm1 tm0)+ case rM of+ Nothing -> do+ send $+ (command $ var progressBar <> ".style.width='100%'") *>+ (command $ var progressBar <> ".classList.add('bg-success')") *>+ (command $ var progressBar <> ".innerHTML=" <> value tm) + Just msg -> do+ print ("doTest failed"::String,msg)+ send $+ (command $ var progressBar <> ".style.width='100%'") *>+ (command $ var progressBar <> ".classList.add('bg-danger')") *>+ (command $ var progressBar <> ".innerHTML=" <> value tm) + +runTests :: Engine -> [Int] -> [Tests] -> IO ()+runTests e p ts = sequence_ [ runTest e (m:n:p) t | (Tests _ ts,n) <- ts `zip` [0..], (t,m) <- ts `zip` [0..] ]++example :: Engine -> IO ()+example e = runTests e [] tests