We planned to upgrade GitLab and Mattermost to the latest version this Friday morning (early). You may experience some downtime!

Verified Commit e406f28c authored by Camil Staps's avatar Camil Staps 🚀

Initial commit

parents
*.abc
*.bc
*.o
*.tcl
definition module Electron.App
from StdMaybe import :: Maybe
from ABC.Interpreter.JavaScript import :: JSVal, :: JSFun, :: JSWorld
from iTasks.WF.Definition import :: Task
:: ElectronProcess
= MainProcess
| RendererProcess !Int
:: TransportMethod
= HyperstrictDynamic
| LazyDynamic
:: ServerToClientWriter stoc :== TransportMethod stoc -> Task ()
:: ServerMessageHandler ctos :== ctos -> Task ()
:: ClientToServerWriter ctos :== TransportMethod ctos *JSWorld -> *JSWorld
:: ClientMessageHandler stoc :== stoc *JSWorld -> *JSWorld
:: UniversalConnectionDetails = ConnectionDetails (A.stoc ctos: ConnectionDetails stoc ctos | TC stoc & TC ctos)
:: ConnectionDetails stoc ctos =
{ serverWrite :: !ServerToClientWriter stoc
, clientWrite :: !ClientToServerWriter ctos
, setClientMessageHandler :: !(ClientMessageHandler stoc) *JSWorld -> *JSWorld
}
:: Connection = E.stoc ctos: Connection (Connection` stoc ctos)
:: Connection` stoc ctos =
{ match :: !Dynamic -> Maybe ctos
, messageHandler :: !ServerMessageHandler ctos
}
serveElectron :: !(ElectronProcess UniversalConnectionDetails -> Task Connection) !*World -> *World
runInElectron :: !ElectronProcess !(JSVal *JSWorld -> *JSWorld) -> Task ()
implementation module Electron.App
import StdEnv
import StdMaybe
from Data.Func import hyperstrict, seqSt
import Data.Functor
import qualified Data.Map
from Data.Map import :: Map, instance Functor (Map k)
import Data.Map.GenJSON
import Data.Tuple
import System._Unsafe
import qualified Text
from Text import class Text, instance Text String
import graph_copy
import TCPIP
import ABC.Interpreter
import ABC.Interpreter.JavaScript
import iTasks
import iTasks.Internal.IWorld
import iTasks.Internal.Task
PORT :== 1234
derive JSONEncode Symbol, PrelinkedInterpretationEnvironment
JSONEncode{|{#Symbol}|} b xs = JSONEncode{|*|} b [x \\ x <-: xs]
JSONEncode{|{#Int}|} b xs = JSONEncode{|*|} b [x \\ x <-: xs]
derive JSONDecode Symbol, PrelinkedInterpretationEnvironment
JSONDecode{|{#Symbol}|} b json = appFst (fmap toArray) (JSONDecode{|*|} b json)
JSONDecode{|{#Int}|} b json = appFst (fmap toArray) (JSONDecode{|*|} b json)
toArray :: [a] -> {#a} | Array {#} a
toArray xs = {#x \\ x <- xs}
instance < ElectronProcess
where
< a b = case a of
MainProcess -> b=:(RendererProcess _)
RendererProcess a -> case b of
MainProcess -> False
RendererProcess b -> a < b
JSONEncode{|Connection|} _ (Connection c) =
[JSONArray [JSONString "_Connection", JSONString (copy_to_string c)]]
JSONDecode{|Connection|} _ json = case json of
[JSONArray [JSONString "_Connection", JSONString s]:json] ->
(Just (fst (copy_from_string {c \\ c <-: s})), json)
_ ->
(Nothing, json)
:: TCPLocal =
{ processId :: !ElectronProcess
, buffer :: !String
}
:: TCPMsg =
{ type :: !String
, val :: !String
}
:: TCPShare =
{ rendererCounter :: !Int
, tcpRx :: !Map ElectronProcess [TCPMsg]
, tcpTx :: !Map ElectronProcess [TCPMsg]
}
derive class iTask ElectronProcess, TCPLocal, TCPMsg, TCPShare
tcpShare :: SimpleSDSLens TCPShare
tcpShare = sharedStore "tcpShare"
{ rendererCounter = 0
, tcpRx = 'Data.Map'.newMap
, tcpTx = 'Data.Map'.newMap
}
tcpConnection :: !ElectronProcess -> SimpleSDSLens (Maybe Connection)
tcpConnection processId = mapReadWrite
( 'Data.Map'.get processId
, \mbConn map -> Just case mbConn of
Nothing -> 'Data.Map'.del processId map
Just conn -> 'Data.Map'.put processId conn map
)
Nothing
(sharedStore "tcpConnections" 'Data.Map'.newMap)
serveElectron :: !(ElectronProcess UniversalConnectionDetails -> Task Connection) !*World -> *World
serveElectron startConnection w = doTasks (onStartup task) w
where
task :: Task ()
task =
getPIE >>- \pie ->
(connect pie -&&- loop pie) @!
()
getPIE :: Task PrelinkedInterpretationEnvironment
getPIE = mkInstantTask \_ iworld=:{IWorld | abcInterpreterEnv} -> (Ok abcInterpreterEnv,iworld)
connect :: !PrelinkedInterpretationEnvironment -> Task ()
connect pie = tcplisten PORT True tcpShare
{ ConnectionHandlers
| onConnect = onConnect
, onData = onData
, onShareChange = onShareChange
, onDisconnect = onDisconnect
, onDestroy = \local -> (Ok local, [])
} @! ()
where
onConnect :: !ConnectionId !String !TCPShare -> (!MaybeErrorString TCPLocal, !Maybe TCPShare, ![String], !Bool)
onConnect _ _ share=:{rendererCounter}
# processId = if (rendererCounter==0) MainProcess (RendererProcess rendererCounter)
# share & rendererCounter = rendererCounter+1
= (Ok {processId=processId, buffer=""}, Just share, [], False)
onData :: !String !TCPLocal !TCPShare -> (!MaybeErrorString TCPLocal, !Maybe TCPShare, ![String], !Bool)
onData data local=:{processId,buffer} share=:{tcpRx}
# buffer = buffer +++ data
# lines = 'Text'.split "\n" buffer
# local & buffer = last lines
# lines = map (fromJSON o fromString) (init lines)
| isEmpty lines
= (Ok local, Nothing, [], False)
| any isNothing lines
# json = toString (toJSON {type="err", val="invalid json"}) +++ "\n"
= (Ok local, Just share, [json], False)
# share & tcpRx = foldr (\(Just msg) -> 'Data.Map'.alter (add msg) processId) tcpRx lines
= (Ok local, Just share, [], False)
where
add :: !TCPMsg !(Maybe [TCPMsg]) -> Maybe [TCPMsg]
add msg mbMsgs = case mbMsgs of
Just msgs -> Just (msgs++[msg])
Nothing -> Just [msg]
onShareChange :: !TCPLocal !TCPShare -> (!MaybeErrorString TCPLocal, !Maybe TCPShare, ![String], !Bool)
onShareChange local=:{processId} share=:{tcpTx}
# tx = fromMaybe [] ('Data.Map'.get processId tcpTx)
| isEmpty tx
= (Ok local, Nothing, [], False)
# share & tcpTx = 'Data.Map'.put processId [] tcpTx
= (Ok local, Just share, [toString (toJSON msg)+++"\n" \\ msg <- tx], False)
onDisconnect :: !TCPLocal !TCPShare -> (!MaybeErrorString TCPLocal, !Maybe TCPShare)
onDisconnect local=:{processId} share=:{tcpTx,tcpRx} =
( Ok local
, Just
{ share
& tcpRx = 'Data.Map'.del processId tcpRx
, tcpTx = 'Data.Map'.del processId tcpTx
}
)
loop :: !PrelinkedInterpretationEnvironment -> Task ()
loop pie =
watch tcpRx >>*
[ OnValue (ifValue (any (not o isEmpty) o 'Data.Map'.elems) return)
] >>- \rx ->
set (const [] <$> rx) tcpRx >-| // TODO: atomic access; iTasks-SDK#370
sequence [handle processId msg \\ (processId,msgs) <- 'Data.Map'.toList rx, msg <- msgs] >-|
loop pie
where
tcpRx = mapReadWrite (\s -> s.tcpRx, \rx s -> Just {s & tcpRx=rx}) Nothing tcpShare
handle :: !ElectronProcess !TCPMsg -> Task ()
handle processId msg =
get (tcpConnection processId) >>- \mbConnection ->
catchAll
(handle` mbConnection)
(\s -> sendTCPMsg processId {type="err",val=s})
where
handle` mbConnection = case mbConnection of
Nothing ->
case msg.TCPMsg.type of
"new" ->
startConnection processId (connectionDetails processId) >>- \conn ->
set (Just conn) (tcpConnection processId) @!
()
_ ->
throw "invalid process id"
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
_ ->
throw "invalid message type"
connectionDetails :: !ElectronProcess -> UniversalConnectionDetails
connectionDetails processId = ConnectionDetails
{ serverWrite = \method val
#! tuple = (0,dynamic val)
#! (_,val) = if (method=:HyperstrictDynamic) (hyperstrict tuple) tuple
-> sendSerializedTCPMsg processId "msg" val
, clientWrite = \method val w
#! tuple = (0,dynamic val)
#! (_,val) = if (method=:HyperstrictDynamic) (hyperstrict tuple) tuple
# (val,w) = jsSerializeOnClient val w
# w = (jsGlobal "ABC" .# "component" .# "send" .$! ("msg", val)) w
-> w
, setClientMessageHandler = \handler w
# (component,w) = jsGlobal "ABC" .# "component" .? w
# fun = \{[1]=val} w -> case unsafeCoerce val of
(val :: stoc^) -> handler val w
_ -> jsTrace "dynamic type mismatch" w // TODO handle gracefully
# (fun,w) = jsWrapFun fun component w
# w = (component .# "message_handler" .= fun) w
-> w
}
runInElectron :: !ElectronProcess !(JSVal *JSWorld -> *JSWorld) -> Task ()
runInElectron processId f = sendSerializedTCPMsg processId "run" (wrapInitFunction f)
sendSerializedTCPMsg :: !ElectronProcess !String a -> Task ()
sendSerializedTCPMsg processId type val =
serialize val >>= \serialized ->
sendTCPMsg processId {type=type, val=serialized}
sendTCPMsg :: !ElectronProcess !TCPMsg -> Task ()
sendTCPMsg processId msg =
upd (\share=:{tcpTx} -> {share & tcpTx='Data.Map'.alter (add msg) processId tcpTx}) tcpShare @!
()
where
add m Nothing = Just [m]
add m (Just q) = Just (q++[m])
serialize :: a -> Task String
serialize graph = mkInstantTask
\id iworld=:{IWorld | abcInterpreterEnv}
# serialized = jsSerializeGraph graph abcInterpreterEnv
-> (Ok serialized, iworld)
definition module Electron.Menu
from Data.Map import :: Map
from ABC.Interpreter.JavaScript import :: JSVal, generic gToJS
from iTasks.UI.Tune import class tune
from Electron.Types import :: EnabledDisabled
:: Menu :== [MenuItem]
:: MenuItem
= MenuSeperator
| MenuItem !String
| CustomMenuItem !(Map String JSVal)
derive gToJS MenuItem
:: SubMenu =: SubMenu Menu
instance tune SubMenu MenuItem
:: MenuItemRole
= Undo | Redo
| Cut | Copy | Paste | PasteAndMatchStyle | Delete
| SelectAll
| Reload | ForceReload
| ToggleDevTools
| ResetZoom | ZoomIn | ZoomOut | Zoom
| ToggleFullScreen
| Window | Minimize | Close | Hide | HideOthers | Unhide | Quit | Front
| Help | About | Services
| StartSpeaking | StopSpeaking
| AppMenu | FileMenu | EditMenu | ViewMenu | WindowMenu
| RecentDocuments | ClearRecentDocuments
| ToggleTabBar | SelectNextTab | SelectPreviousTab
| MergeAllWindows | MoveTabToNewWindow
instance tune MenuItemRole MenuItem
:: MenuAccelerator =: Accelerator String
instance tune MenuAccelerator MenuItem
instance tune EnabledDisabled MenuItem
:: MenuItemType = Checkbox | Radio
instance tune MenuItemType MenuItem
implementation module Electron.Menu
import StdEnv
import Data.GenCons
import qualified Data.Map
from Data.Map import :: Map
import ABC.Interpreter.JavaScript
import iTasks.UI.Tune
import Electron.Types
gToJS{|MenuItem|} mi = case mi of
CustomMenuItem settings
-> toJS (JSRecord settings)
-> toJS (toCustomMenuItem mi)
toCustomMenuItem :: !MenuItem -> MenuItem
toCustomMenuItem mi = case mi of
MenuSeperator -> CustomMenuItem ('Data.Map'.singleton "type" (toJS "separator"))
MenuItem s -> CustomMenuItem ('Data.Map'.singleton "label" (toJS s))
withOption :: !String !a !MenuItem -> MenuItem | gToJS{|*|} a
withOption key val mi = case mi of
CustomMenuItem opts
-> CustomMenuItem ('Data.Map'.put key (toJS val) opts)
-> withOption key val (toCustomMenuItem mi)
instance tune SubMenu MenuItem
where
tune (SubMenu menu) mi = withOption "submenu" menu mi
instance tune MenuItemRole MenuItem
where
tune role mi = withOption "role" (toString role) mi
derive consName MenuItemRole
instance toString MenuItemRole
where
toString mir = let name = consName{|*|} mir in name := (0, toLower name.[0])
instance tune MenuAccelerator MenuItem
where
tune (Accelerator a) mi = withOption "accelerator" a mi
instance tune EnabledDisabled MenuItem
where
tune eord mi = withOption "enabled" (eord=:Enabled) mi
instance tune MenuItemType MenuItem
where
tune type mi = withOption "type" (toString type) mi
instance toString MenuItemType
where
toString mit = case mit of
Checkbox -> "checkbox"
Radio -> "radio"
definition module Electron.Types
:: EnabledDisabled = Enabled | Disabled
implementation module Electron.Types
const fs=require ('fs').promises;
const net=require ('net');
const path=require ('path');
const spawn=require ('child_process').spawn;
const {app}=require ('electron');
/* This module is assumed to be called from the iTasks -www directory. This
* directory also contains abc-interpreter.js, so we can do a relative import.
* Because path.join does not keep `./`, we use path.sep instead. */
const ABC_INTERPRETER=require ('.'+path.sep+'abc-interpreter.js');
const {ABCInterpreter,SharedCleanValue,CleanHeapValue}=ABC_INTERPRETER;
class Component {
static instantiate (opts) {
return ABCInterpreter.instantiate ({
bytecode_path: opts.app+'.pbc',
heap_size: 20<<20,
stack_size: 500<<10,
with_js_ffi: true,
encoding: 'utf-8',
fetch: path => {
if (path.indexOf('/js/')==0)
path='./'+opts.app+'-www'+path;
return fs.readFile (path).then (buffer => ({
ok: true,
arrayBuffer: () => buffer.buffer
}));
},
}).then (abc => {
const socket=net.createConnection (opts.port,opts.host,() => {
socket.write (JSON.stringify ({type: 'new', val: ''}) + '\n');
});
const component=new Component (abc,socket);
if (typeof opts.debug!='undefined')
component.do_debug=opts.debug;
abc.component=component;
return component;
});
}
constructor (abc,socket) {
this.abc=abc;
this.socket=socket;
this.message_handler=null;
this.shared_clean_values=null;
this.do_debug=false;
this.buffer='';
this.socket.on ('data',this.onData.bind (this));
this.socket.on ('close',() => {
console.log ('server exited');
// TODO how to handle this?
});
this.socket.on ('error',err => {
console.log ('connection error:',err.message);
// TODO how to handle this?
});
}
debug () {
if (this.do_debug)
console.log.apply (null,arguments);
}
onData (data) {
data=this.buffer+data.toString();
const lines=data.split ('\n');
this.buffer=lines.pop();
lines.forEach (data => {
data=JSON.parse (data);
this.debug ('<--',data);
switch (data.type){
case 'msg':
this.handleMsg (data.val);
break;
case 'run':
this.run (data.val);
break;
default:
throw new Error ('unknown message type "'+data.type+'"');
}
});
}
send (type,val) {
const json={
type: type,
val: val
};
this.debug ('-->',json);
this.socket.write (JSON.stringify (json) + '\n');
}
/* fun is a base64-encoded serialized Clean function wrapped with
* wrapInitFun */
run (fun) {
const val=this.abc.deserialize (Buffer.from (fun,'base64'));
const ref=this.abc.share_clean_value (val,this);
const args=[this, this.abc.initialized ? 0 : 1];
this.abc.interpret (new SharedCleanValue (ref),args);
}
/* val is a base64-encoded serialized Dynamic */
handleMsg (val) {
if (this.message_handler==null){
console.log ('handleMsg called before a message handler was defined');
return;
}
val=this.abc.deserialize (Buffer.from (val,'base64'));
const args=[this, new CleanHeapValue (val)];
this.abc.interpret (this.message_handler,args);
}
}
const DEFAULTS={
host: 'localhost',
port: 1234,
debug: true
};
function run (_opts) {
const opts=DEFAULTS;
Object.assign (opts,_opts);
const server=spawn ('./'+opts.app,{stdio: 'inherit'});
server.on ('close',code => {
if (code!==0 && code!==null)
console.log ('iTasks exited with exit code '+code);
app.quit(code);
});
process.on ('exit',() => server.kill (9));
// TODO: this assumes that the iTasks server has started up by the time we
// have initialized the ABC interpreter, which might not be the case
return Component.instantiate (opts);
}
function connect (_opts) {
const opts=DEFAULTS;
Object.assign (opts,_opts);
return Component.instantiate (opts);
}
module.exports={
run: run,
connect: connect
};
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