Verified Commit 29e56416 authored by Camil Staps's avatar Camil Staps 🚀

Add runOnServer

parent 2eac292b
......@@ -2,6 +2,7 @@ definition module Electron.App
from StdMaybe import :: Maybe
from ABC.Interpreter.JavaScript import :: JSVal, :: JSFun, :: JSWorld
from ABC.Interpreter.JavaScript.Monad import :: JS
from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode
from iTasks.Engine import :: EngineOptions
from iTasks.SDS.Definition import :: SimpleSDSLens, :: SDSLens
......@@ -45,3 +46,21 @@ serveElectron ::
!*World -> *World
runInElectron :: !ElectronProcess !(JSVal *JSWorld -> *JSWorld) -> Task ()
/**
* Perform a {{`Task`}} on the server and continue with its result on the
* client.
*
* This function is meant to be run on the client.
*
* The client continuation will only be run once the server task has reached a
* stable value.
*
* @param The component to work with.
* @param The task to perform on the server.
* @param The continuation on the client, executed when the task has reached a
* stable value.
* @result The result value is always `jsNull`; it is not `()` to make it
* easier to integrate this function in a monad chain.
*/
runOnServer :: !JSVal !(Task a) (a -> JS st b) -> JS st JSVal | TC, JSONEncode{|*|} a
......@@ -3,8 +3,10 @@ implementation module Electron.App
import StdEnv
import StdMaybe
import Control.Monad => qualified return, forever, sequence
from Data.Func import hyperstrict, seqSt
import Data.Functor
import Data.List
import qualified Data.Map
from Data.Map import :: Map, instance Functor (Map k)
import Data.Map.GenJSON
......@@ -19,8 +21,9 @@ import TCPIP
import ABC.Interpreter
import ABC.Interpreter.JavaScript
import ABC.Interpreter.JavaScript.Monad
import iTasks
import iTasks => qualified forever
import iTasks.Internal.IWorld
import iTasks.Internal.Task
......@@ -60,8 +63,9 @@ JSONDecode{|Connection|} _ json = case json of
}
:: TCPMsg =
{ type :: !String
, val :: !String
{ type :: !String
, val :: !String
, extra :: ![(String, JSONNode)]
}
:: TCPShare =
......@@ -70,7 +74,20 @@ JSONDecode{|Connection|} _ json = case json of
, tcpTx :: !Map ElectronProcess [TCPMsg]
}
derive class iTask ElectronProcess, TCPLocal, TCPMsg, TCPShare
derive class iTask ElectronProcess, TCPLocal, TCPShare
JSONEncode{|TCPMsg|} _ {type,val,extra} = [JSONObject [("type",JSONString type),("val",JSONString val):extra]]
JSONDecode{|TCPMsg|} _ [JSONObject obj:json] =
case (lookup "type" obj, lookup "val" obj) of
(Just (JSONString type), Just (JSONString val)) ->
(Just {type=type, val=val, extra=[kv \\ kv=:(k,_) <- obj | k <> "type" && k <> "val"]}, json)
_ ->
(Nothing, json)
JSONDecode{|TCPMsg|} _ json = (Nothing, json)
derive gEq TCPMsg
derive gText TCPMsg
derive gEditor TCPMsg
tcpShare :: SimpleSDSLens TCPShare
tcpShare =: sdsFocus "tcpShare" (memoryStore "Electron" (Just
......@@ -145,7 +162,7 @@ where
| isEmpty lines
= (Ok local, Nothing, [], False)
| any isNothing lines
# json = toString (toJSON {type="err", val="invalid json"}) +++ "\n"
# json = toString (toJSON {type="err", val="invalid json", extra=[]}) +++ "\n"
= (Ok local, Just share, [json], False)
# share & tcpRx = 'Data.Map'.alter (add [l \\ Just l <- lines]) processId tcpRx
= (Ok local, Just share, [], False)
......@@ -189,7 +206,7 @@ where
get (tcpConnection processId) >>- \mbConnection ->
catchAll
(handle` mbConnection)
(\s -> sendTCPMsg processId {type="err",val=s})
(\s -> sendTCPMsg processId {type="err", val=s, extra=[]})
where
handle` mbConnection = case mbConnection of
Nothing ->
......@@ -200,15 +217,21 @@ where
()
_ ->
throw "invalid process id"
Just (Connection c) ->
case msg.TCPMsg.type of
Just (Connection c)
-> case msg.TCPMsg.type of
"msg"
# (dyn,r) = jsDeserializeFromClient msg.val pie
| r <> 0
-> throw "failed to deserialize"
-> case c.match dyn of
Nothing -> throw "dynamic type mismatch"
Just m -> c.messageHandler m
| r <> 0 ->
throw "failed to deserialize"
| otherwise -> case c.match dyn of
Nothing -> throw "dynamic type mismatch"
Just m -> c.messageHandler m
"request"
# (task_with_cont,r) = jsDeserializeFromClient msg.val pie
| r <> 0 ->
throw "failed to deserialize"
| otherwise ->
task_with_cont (sendSerializedTCPMsg processId "response" msg.extra)
_ ->
throw "invalid message type"
......@@ -217,7 +240,7 @@ where
{ serverWrite = \method val
#! tuple = (0,dynamic val)
#! (_,val) = if (method=:HyperstrictDynamic) (hyperstrict tuple) tuple
-> sendSerializedTCPMsg processId "msg" val
-> sendSerializedTCPMsg processId "msg" [] val
, clientWrite = \method val w
#! tuple = (0,dynamic val)
#! (_,val) = if (method=:HyperstrictDynamic) (hyperstrict tuple) tuple
......@@ -240,12 +263,32 @@ parseBaseOptions ["--port":p:rest] opts =
parseBaseOptions cli opts = (cli,opts)
runInElectron :: !ElectronProcess !(JSVal *JSWorld -> *JSWorld) -> Task ()
runInElectron processId f = sendSerializedTCPMsg processId "run" (wrapInitFunction f)
sendSerializedTCPMsg :: !ElectronProcess !String a -> Task ()
sendSerializedTCPMsg processId type val =
runInElectron processId f = sendSerializedTCPMsg processId "run" [] (wrapInitFunction f)
runOnServer :: !JSVal !(Task a) (a -> JS st b) -> JS st JSVal | TC, JSONEncode{|*|} a
runOnServer comp task cont =
accJS ((.?) (comp .# "request_id")) >>= \jsval ->
let request_id = jsValToInt` 0 jsval in
appJS (comp .# "request_id" .= request_id+1) >>|
gets id >>= \{JSState | state} ->
accJS (jsWrapFun (wrapped_cont request_id state) comp) >>= \cont ->
appJS (comp .# "response_handlers" .# "set" .$! (request_id, cont)) >>|
accJS (jsSerializeOnClient (\cont -> task >>- cont)) >>= \task ->
appJS (comp .# "send" .$! ("request", task, jsRecord ["id" :> request_id])) >>|
pure jsNull
where
wrapped_cont request_id state {[0]=result} w
# (handler,w) = (comp .# "response_handlers" .# "get" .$ request_id) w
# w = jsFreeCleanReference handler w
# w = (comp .# "response_handlers" .# "delete" .$! request_id) w
# (result,w) = jsDeserializeGraph {c \\ c <-: jsValToString` "" result} w
# (_,w) = runJS state comp (cont result) w
= w
sendSerializedTCPMsg :: !ElectronProcess !String ![(String, JSONNode)] a -> Task ()
sendSerializedTCPMsg processId type extra val =
serialize val >>- \serialized ->
sendTCPMsg processId {type=type, val=serialized}
sendTCPMsg processId {type=type, val=serialized, extra=extra}
sendTCPMsg :: !ElectronProcess !TCPMsg -> Task ()
sendTCPMsg processId msg =
......
......@@ -49,6 +49,9 @@ class Component {
this.shared_clean_values=null;
this.do_debug=false;
this.response_handlers=new Map();
this.request_id=0;
this.buffer='';
this.socket.on ('data',this.onData.bind (this));
this.socket.on ('close',() => {
......@@ -82,17 +85,25 @@ class Component {
case 'run':
this.run (data.val);
break;
case 'response':
this.abc.interpret (this.response_handlers.get (data.id),[data.val]);
break;
default:
throw new Error ('unknown message type "'+data.type+'"');
}
});
}
send (type,val) {
send (type,val,extra) {
const json={
type: type,
val: val
};
if (typeof extra!='undefined')
for (var k in extra)
json[k]=extra[k];
this.debug ('-->',json);
this.socket.write (JSON.stringify (json) + '\n');
}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment