Verified Commit c29612ee authored by Camil Staps's avatar Camil Staps

Merge remote-tracking branch 'origin/master' into...

Merge remote-tracking branch 'origin/master' into server-and-client-side-svg-rendering-with-abc-interpreter
parents 1490da35 7eedec78
Version: 1.5
Global
ProjectRoot: .
Target: iTasks
CodeGen
CheckStacks: False
CheckIndexes: True
OptimiseABC: True
GenerateByteCode: True
Application
HeapSize: 167772160
StackSize: 1048576
ExtraMemory: 81920
IntialHeapSize: 204800
HeapSizeMultiplier: 4096
ShowExecutionTime: False
ShowGC: False
ShowStackSize: False
MarkingCollector: False
DisableRTSFlags: False
StandardRuntimeEnv: True
Profile
Memory: False
MemoryMinimumHeapSize: 0
Time: False
Stack: False
Dynamics: True
GenericFusion: False
DescExL: True
Output
Output: ShowConstructors
Font: Courier
FontSize: 9
WriteStdErr: False
Link
LinkMethod: Static
GenerateRelocations: False
GenerateSymbolTable: False
GenerateLinkMap: False
LinkResources: False
ResourceSource:
GenerateDLL: False
ExportedNames:
StripByteCode: True
KeepByteCodeSymbols: True
PrelinkByteCode: True
Paths
Path: {Project}
Precompile:
Postlink:
......@@ -111,7 +111,7 @@ where
("Specify the HTTP port (default: " +++ toString defaults.serverPort +++ ")")
, Option [] ["timeout"] (OptArg (\mp->fmap \o->{o & timeout=fmap toInt mp}) "MILLISECONDS")
"Specify the timeout in ms (default: 500)\nIf not given, use an indefinite timeout."
, Option [] ["allowed-hosts"] (ReqArg (\p->fmap \o->{o & allowedHosts = split "," p}) "IPADRESSES")
, Option [] ["allowed-hosts"] (ReqArg (\p->fmap \o->{o & allowedHosts = if (p == "") [] (split "," p)}) "IPADRESSES")
("Specify a comma separated white list of hosts that are allowed to connected to this application\ndefault: "
+++ join "," defaults.allowedHosts)
, Option [] ["keepalive"] (ReqArg (\p->fmap \o->{o & keepaliveTime={tv_sec=toInt p,tv_nsec=0}}) "SECONDS")
......@@ -273,10 +273,13 @@ where
where
getTimeoutFromClock` :: (!SDSNotifyRequest, !Timespec) -> Maybe Timeout
getTimeoutFromClock` (snr=:{cmpParam=(ts :: ClockParameter Timespec)}, reqTimespec)
| startsWith "$IWorld:timespec$" snr.reqSDSId && ts.interval <> zero
| dependsOnClock snr && ts.interval <> zero
# fire = iworldTimespecNextFire now reqTimespec ts
= Just (max 0 (toMs fire - toMs now))
= mt
getTimeoutFromClock` _ = mt
dependsOnClock :: !SDSNotifyRequest -> Bool
dependsOnClock snr = indexOf "$IWorld:timespec$" snr.reqSDSId >= 0
toMs x = x.tv_sec * 1000 + x.tv_nsec / 1000000
......@@ -2,6 +2,7 @@ definition module iTasks.Extensions.Email
/**
* This module provides basic SMTP email support
*/
from Text.HTML import :: HtmlTag
import iTasks
/**
......@@ -9,11 +10,22 @@ import iTasks
*
* @param Options: Mail server options, when left blank port 25 on localhost is used SMTP server
* @param Sender: The sender address
* @param Recipient: The recipient address
* @param Recipients: The recipient addresses
* @param Subject: The subject line of the e-mail message
* @param Body: The body of the e-mail message
*/
sendEmail :: ![EmailOpt] !String !String !String !String -> Task ()
sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
/**
* Send an e-mail message with HTML body.
*
* @param Options: Mail server options, when left blank port 25 on localhost is used SMTP server
* @param Sender: The sender address
* @param Recipients: The recipient addresses
* @param Subject: The subject line of the e-mail message
* @param Body: The HTML body of the e-mail message
*/
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
//Options for sendEmail
:: EmailOpt
......
implementation module iTasks.Extensions.Email
import iTasks
import Text
import Data.Functor, Data.Func
import Text, Text.HTML
sendEmail :: ![EmailOpt] !String !String !String !String -> Task ()
sendEmail opts subject body sender recipient
= tcpconnect server port (constShare ()) {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect,onDestroy= \s->(Ok s, [])}
sendEmail :: ![EmailOpt] !String ![String] !String !String -> Task ()
sendEmail opts sender recipients subject body
= tcpconnect server port (constShare ()) {ConnectionHandlers|onConnect=onConnect,onData=onData,onDisconnect=onDisconnect,onShareChange = \l _ = (Ok l, Nothing, [], False), onDestroy= \s->(Ok s, [])}
@! ()
where
server = getServerOpt opts
......@@ -14,37 +16,47 @@ where
//but we send it in parts. After each part we get a response with a status code.
//After each message we check if it is a status code we expect.
messages =
[("",220) //Initially we don't send anything, but wait for the welcome message from the server
,(smtpHelo, 250)
,(smtpFrom sender, 250)
,(smtpTo recipient, 250)
,(smtpData, 354)
,(smtpBody sender recipient headers subject body, 250)
,(smtpQuit, 221)
]
[("",220) //Initially we don't send anything, but wait for the welcome message from the server
,(smtpHelo, 250)
,(smtpFrom sender, 250)
]
++
((\recipient -> (smtpTo recipient, 250)) <$> recipients)
++
[(smtpData, 354)
,(smtpBody sender recipients headers subject body, 250)
,(smtpQuit, 221)
]
//Send the first message
onConnect _ _
onConnect :: !ConnectionId !String !() -> (!MaybeErrorString [(!String, !Int)], !Maybe (), ![String], !Bool)
onConnect _ _ _
= (Ok messages,Nothing,[],False)
//Response to last message: if ok, close connection
whileConnected (Just data) [(_,expectedCode)] _
onData :: !String ![(!String, !Int)] !() -> (!MaybeErrorString [(!String, !Int)], !Maybe (), ![String], !Bool)
onData data [(_,expectedCode)] _
| statusCode data == expectedCode
= (Ok [],Nothing,[],True)
= (Error data,Nothing,[],False)
//Response to other messages: if ok, send next message
whileConnected (Just data) [(_,expectedCode):ms] _
onData data [(_,expectedCode):ms] _
| statusCode data == expectedCode
= (Ok ms,Nothing,[fst (hd ms)],False)
= (Error data,Nothing,[],False)
//All other cases: just wait
whileConnected _ state _
= (Ok state,Nothing,[],False)
//We don't expect the server to disconnect before we close
//the connection ourselves
onDisconnect _ _
= (Error "SMTP server disconnected unexpectedly",Nothing)
sendHtmlEmail :: ![EmailOpt] !String ![String] !String !HtmlTag -> Task ()
sendHtmlEmail opts sender recipients subject body =
sendEmail [EmailOptExtraHeaders [("content-type", "text/html")]: opts] sender recipients subject htmlString
where
// avoid too long lines (SMTP allows a max length of 1000 characters only)
// by inserting a newline (\r\n is required for mails) after each tag
htmlString = replaceSubString ">" ">\r\n" $ toString body
// SMTP messages
smtpHelo = "HELO localhost\r\n"
smtpFrom email_from = "MAIL FROM:<" +++ (cleanupEmailString email_from) +++ ">\r\n"
......@@ -53,8 +65,9 @@ smtpData = "DATA\r\n"
smtpBody email_from email_to email_headers email_subject email_body
= concat [k+++":"+++ v +++ "\r\n" \\ (k,v) <-
[("From",cleanupEmailString email_from)
,("To",cleanupEmailString email_to)
,("Subject",cleanupEmailString email_subject)
: (\email_to -> ("To",cleanupEmailString email_to)) <$> email_to
] ++
[("Subject",cleanupEmailString email_subject)
:email_headers]
]
+++ "\r\n" +++ email_body +++ "\r\n.\r\n"
......@@ -79,5 +92,5 @@ getPortOpt [EmailOptSMTPServerPort s:xs] = s
getPortOpt [x:xs] = getPortOpt xs
getHeadersOpt [] = []
getHeadersOpt [EmailOptExtraHeaders s:xs] = s
getHeadersOpt [EmailOptExtraHeaders s:xs] = s ++ getHeadersOpt xs
getHeadersOpt [x:xs] = getHeadersOpt xs
......@@ -179,6 +179,12 @@ where
# world = (me .# "afterChildInsert" .= cb) world
# (cb,world) = jsWrapFun (\a w -> onBeforeChildRemove me a w) me world
# world = (me .# "beforeChildRemove" .= cb) world
# (cb,world) = jsWrapFun (\a w -> onViewportChange me w) me world
# world = (me .# "onViewportChange" .= cb) world
# (vp,world) = (me .# "getViewport" .$ ()) world
# world = (vp .# "addChangeListener" .$! me) world
# (cb,world) = jsWrapFun (\a w -> beforeRemove me w) me world
# world = (me .# "beforeRemove" .= cb) world
# world = case viewMode of
True
= world
......@@ -272,6 +278,16 @@ where
# (mapObj,world) = me .# "map" .? world
= (mapObj.# "removeLayer" .$! popup) world
onViewportChange me world
# (mapObj,world) = me .# "map" .? world
# world = (mapObj .# "invalidateSize" .$! ()) world
= world
beforeRemove me world
# (vp,world) = (me .# "getViewport" .$ ()) world
# world = (vp .# "removeChangeListener" .$! me) world
= world
onWindowRemove me windowId _ world
// remove children from iTasks component
# (children,world) = me .# "children" .? world
......
......@@ -134,11 +134,18 @@ httpServer port keepAliveTime requestProcessHandlers sds
= wrapIWorldConnectionTask {ConnectionHandlersIWorld|onConnect=onConnect, onData=onData, onShareChange=onShareChange, onTick=onTick, onDisconnect=onDisconnect, onDestroy=onDestroy} sds
where
onConnect connId host r iworld=:{IWorld|world,clock,options={allowedHosts}}
| allowedHosts =: [] || isMember host allowedHosts
| isAllowed host allowedHosts
= (Ok (NTIdle host clock),Nothing,[],False,{IWorld|iworld & world = world})
| otherwise
//Close the connection immediately if the remote host is not in the whitelist
= (Ok (NTIdle host clock),Nothing,[],True,{IWorld|iworld & world = world})
where
//Simple check to also match (sub)networks such as 192.168.0.0 or 0.0.0.0
isAllowed host [] = True
isAllowed host hosts = any (allowedIP (split "." host)) (map (split ".") hosts)
allowedIP [h1,h2,h3,h4] [p1,p2,p3,p4]
= (p1 == "0" || h1 == p1) && (p2 == "0" || h2 == p2) && (p3 == "0" || h3 == p3) && (p4 == "0" || h4 == p4)
allowedIP _ _ = False
onData data connState=:(NTProcessingRequest request localState) r env
//Select handler based on request path
......
......@@ -22,9 +22,7 @@
<!-- load iTasks viewport -->
<script type="text/javascript">
window.onload = function() {
ABC.loading_promise.finally(function(){
itasks.viewport({syncTitle: true}, document.body);
});
itasks.viewport({syncTitle: true}, document.body);
};
</script>
</head>
......
......@@ -389,7 +389,7 @@ ABC.loading_promise=fetch('js/app.pbc').then(function(resp){
ABC.memory=new WebAssembly.Memory({initial: blocks_needed});
ABC.memory_array=new Uint32Array(ABC.memory.buffer);
for (var i in ABC.prog)
for (var i=0; i<ABC.prog.length; i++)
ABC.memory_array[i]=ABC.prog[i];
(function(prog){
......
......@@ -26,32 +26,35 @@ itasks.Component = {
init: function() {
var me = this;
me.lastFire = 0;
me.initUI();
me.initComponent();
me.initChildren();
me.renderComponent();
me.initialized = true;
return me;
return Promise.resolve()
.then(me.initUI.bind(me))
.then(me.initComponent.bind(me))
.then(me.initChildren.bind(me))
.then(me.renderComponent.bind(me))
.then(function(){ me.initialized=true; });
},
initUI: function() {
var me=this;
if (me.attributes.initUI!=null && me.attributes.initUI!='') {
var initUI=ABC.deserialize(me.attributes.initUI);
var ref=ABC.share_clean_value(initUI,me);
ABC.interpret(SharedCleanValue(ref), [me, ABC.initialized ? 0 : 1]);
ABC.clear_shared_clean_value(ref);
return ABC.loading_promise.then(function(){
var initUI=ABC.deserialize(me.attributes.initUI);
var ref=ABC.share_clean_value(initUI,me);
ABC.interpret(SharedCleanValue(ref), [me, ABC.initialized ? 0 : 1]);
ABC.clear_shared_clean_value(ref);
});
}
},
initComponent: function() {}, //Abstract method: every component implements this differently
initChildren: function() {
var me = this;
me.children.forEach(function(spec,i) {
return me.children.reduce((promise,spec,i) => promise.then(function(){
me.beforeChildInsert(i,spec);
me.children[i] = me.createChild(spec);
me.children[i].init();
me.afterChildInsert(i,me.children[i]);
});
return me.children[i].init().then(function(){
me.afterChildInsert(i,me.children[i]);
});
}), Promise.resolve());
},
renderComponent: function() {
var me = this;
......@@ -183,24 +186,29 @@ itasks.Component = {
//Add the child to the collection of children
me.children.splice(idx,0,child);
var finish_up=function(){
me.afterChildInsert(idx,child);
if (child.onResize)
child.onResize();
};
if(me.initialized) {
//Initialize, if we are already initialized
child.init();
//Add the child to the dom
if(child.domEl) {
if(isLast) {
me.containerEl.appendChild(child.domEl);
} else {
me.containerEl.insertBefore(child.domEl,me.containerEl.childNodes[idx]);
return child.init().then(function(){
//Add the child to the dom
if(child.domEl) {
if(isLast) {
me.containerEl.appendChild(child.domEl);
} else {
me.containerEl.insertBefore(child.domEl,me.containerEl.childNodes[idx]);
}
child.onShow();
}
child.onShow();
}
}
me.afterChildInsert(idx,child);
//When the child is first added, we trigger a resize event
if(child.onResize) {
child.onResize();
finish_up();
});
} else {
finish_up();
}
},
beforeChildInsert: function(idx,spec) {},
......@@ -220,7 +228,7 @@ itasks.Component = {
var me = this;
if(idx >= 0 && idx < me.children.length) {
me.removeChild(idx);
me.insertChild(idx,spec);
return me.insertChild(idx,spec);
}
},
moveChild: function(sidx,didx) {
......@@ -267,24 +275,21 @@ itasks.Component = {
if(change) {
switch(change.type) {
case 'replace':
me.onReplaceUI(change.definition);
break;
return me.onReplaceUI(change.definition);
case 'change':
me.onChangeUI(change.attributes,change.children);
break;
return me.onChangeUI(change.attributes,change.children);
}
}
},
onReplaceUI: function(spec) {
var me = this, idx;
var me = this;
if(me.parentCmp) {
idx = me.parentCmp.findChild(me);
me.parentCmp.replaceChild(idx,spec);
var idx = me.parentCmp.findChild(me);
return me.parentCmp.replaceChild(idx,spec);
}
},
onChangeUI: function(attributeChanges,childChanges) {
var me = this, idx;
var me = this;
//Handle attribute changes
if(attributeChanges instanceof Array) {
......@@ -294,19 +299,18 @@ itasks.Component = {
}
//Handle child changes
if (childChanges instanceof Array) {
childChanges.forEach(function(change) {
childChanges.reduce((promise,change) => promise.then(function(){
var idx = change[0];
switch(change[1]) {
case 'change':
if(idx >= 0 && idx < me.children.length) {
me.children[idx].onUIChange(change[2]);
return me.children[idx].onUIChange(change[2]);
} else {
console.log("UNKNOWN CHILD",idx,me.children.length,change);
}
break;
case 'insert':
me.insertChild(idx,change[2]);
break;
return me.insertChild(idx,change[2]);
case 'remove':
me.removeChild(idx);
break;
......@@ -314,7 +318,7 @@ itasks.Component = {
me.moveChild(idx,change[2]);
break;
}
});
}), Promise.resolve());
}
},
onShow: function() {
......@@ -326,6 +330,16 @@ itasks.Component = {
onResize: function() {
this.children.forEach(function(child) { if(child.onResize) {child.onResize();}});
},
getViewport: function() {
var me = this, vp = me.parentCmp;
while(vp) {
if(vp.cssCls == 'viewport') { //Bit of a hack...
return vp;
}
vp = vp.parentCmp;
}
return null;
}
};
itasks.Loader = {
cssCls: 'loader',
......@@ -371,6 +385,8 @@ itasks.Viewport = {
var uiChangeCallback = me.onInstanceUIChange.bind(me);
var exceptionCallback = me.onException.bind(me);
me.changeListeners = [];
if('instanceNo' in me.attributes) {
//Connect to an existing task instance
me.connection.attachTaskInstance(
......@@ -438,6 +454,20 @@ itasks.Viewport = {
});
}
}
//Trigger changelisteners
me.changeListeners.forEach(function(cl) {
cl.onViewportChange(change);
});
},
addChangeListener: function(cmp) {
var me = this;
me.changeListeners.push(cmp);
},
removeChangeListener: function(cmp) {
var me = this;
me.changeListeners = me.changeListeners.filter(function(el) {
return el != cmp;
});
},
onException: function(exception) {
var me = this;
......@@ -463,7 +493,7 @@ itasks.Viewport = {
//use the generic incremental change mechanism to update parts of a Component
//This can be used for example to incrementally update the list of options in a dropdown component
itasks.Data = {
init: function () { return this; },
init: function () { return Promise.resolve(); },
beforeRemove: function() {},
_beforeRemove: function() {},
};
......
......@@ -49,9 +49,10 @@ where
eval DestroyEvent evalOpts (TCBasic taskId ts jsonph _) iworld
# iworld = clearTaskSDSRegistrations ('DS'.singleton taskId) iworld
= apIWTransformer iworld
$ tuple (fjson jsonph)
>-= \(ph, _)->liftOSErr (terminateProcess ph)
>-= \_ ->tuple (Ok DestroyedResult)
$ tuple (fjson jsonph)
>-= \(ph, pio)->liftOSErr (terminateProcess ph)
>-= \_ ->liftOSErr (closeProcessIO pio)
>-= \_ ->tuple (Ok DestroyedResult)
//Destroyed when the task was already stable
eval DestroyEvent evalOpts tree iworld
......
module TestLeafletResize
import iTasks
import iTasks.Extensions.GIS.Leaflet
test = (viewInformation "Map resizing" [] {LeafletMap|perspective=defaultValue,objects=objects,tilesUrls=[],icons=[]} <<@ FlexInner <<@ AddCSSClass "itasks-flex-height")
-|| (updateInformation "List to force resizing" [] [1,2,3,4] <<@ AddCSSClass "itasks-wrap-height")
where
objects = [Polygon {polygonId = LeafletObjectID "poly", points = points,style=[], editable = True}]
points = [{LeafletLatLng|lat=52.0,lng=7.0},{LeafletLatLng|lat=54.0,lng=7.0},{LeafletLatLng|lat=52.0,lng=5.0}]
FlexInner :== ApplyLayout (layoutSubUIs (SelectByPath [1]) (setUIAttributes (heightAttr FlexSize)))
Start world = doTasks test world
......@@ -3,6 +3,9 @@ module iTasks.Internal.IWorld.UnitTests
import Data.Either
import iTasks.Util.Testing
import iTasks.Internal.IWorld
import System.Time
derive gPrint Timespec
testInitIWorld = assertWorld "Init IWorld" id sut
where
......@@ -16,6 +19,22 @@ where
# world = destroyIWorld iworld
= (True,world)
tests = [testInitIWorld]
testIworldTimespecNextFireZero = assertEqual "Next Fire Zero" exp sut
where
exp = {tv_sec=12319,tv_nsec=100}
sut = iworldTimespecNextFire
{tv_sec=12319,tv_nsec=100}
{tv_sec=12314,tv_nsec=50}
{start={tv_sec=0,tv_nsec=1},interval={tv_sec=0,tv_nsec=0}}
testIworldTimespecNextFireOne= assertEqual "Next Fire One" exp sut
where
exp = {tv_sec=12315,tv_nsec=1}
sut = iworldTimespecNextFire
{tv_sec=12319,tv_nsec=100}
{tv_sec=12314,tv_nsec=50}
{start={tv_sec=0,tv_nsec=1},interval={tv_sec=1,tv_nsec=0}}
tests = [testInitIWorld,testIworldTimespecNextFireZero, testIworldTimespecNextFireOne]
Start world = runUnitTests tests world
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