{-# 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]