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