Commit 82c8c416 authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'master' into ui-reorg

# Conflicts:
#	Dependencies/clean-platform
#	Server/iTasks/_Framework/Engine.icl
#	Server/iTasks/_Framework/TaskServer.icl
parents 51cdc0cf 871d16c6
Subproject commit 39a70914d16744646679de573b012cd494fea052 Subproject commit 4a65aaeaf40e3754c6b53a0574bda2786e861e47
*.[aso]
Clean System Files/*.o
...@@ -22,12 +22,12 @@ copy_string_to_graph_interface.o: copy_string_to_graph_interface.s ...@@ -22,12 +22,12 @@ copy_string_to_graph_interface.o: copy_string_to_graph_interface.s
cp copy_string_to_graph_interface.o "Clean System Files"/copy_string_to_graph_interface.o cp copy_string_to_graph_interface.o "Clean System Files"/copy_string_to_graph_interface.o
cleanup: cleanup:
rm copy_graph_to_string.o rm -f copy_graph_to_string.o
rm copy_graph_to_string_interface.o rm -f copy_graph_to_string_interface.o
rm copy_string_to_graph.o rm -f copy_string_to_graph.o
rm copy_string_to_graph_interface.o rm -f copy_string_to_graph_interface.o
rm "Clean System Files"/copy_graph_to_string.o rm -f "Clean System Files"/copy_graph_to_string.o
rm "Clean System Files"/copy_graph_to_string_interface.o rm -f "Clean System Files"/copy_graph_to_string_interface.o
rm "Clean System Files"/copy_string_to_graph.o rm -f "Clean System Files"/copy_string_to_graph.o
rm "Clean System Files"/copy_string_to_graph_interface.o rm -f "Clean System Files"/copy_string_to_graph_interface.o
...@@ -639,7 +639,7 @@ text x = TdTag [AlignAttr "center"] [Text (toString x)] ...@@ -639,7 +639,7 @@ text x = TdTag [AlignAttr "center"] [Text (toString x)]
TileTag :: !(!Int,!Int) !String -> HtmlTag TileTag :: !(!Int,!Int) !String -> HtmlTag
TileTag (width,height) tile TileTag (width,height) tile
= ImgTag [SrcAttr ("/"<+++ tile <+++ ".png"),w,h] = ImgTag [SrcAttr ("/"<+++ tile <+++ ".png"), StyleAttr "min-height:0;",w,h]
where where
(w,h) = (WidthAttr (toString width),HeightAttr (toString height)) (w,h) = (WidthAttr (toString width),HeightAttr (toString height))
......
...@@ -24,6 +24,17 @@ RELATIVE_LOCATIONS :== [".": take 5 (iterate ((</>) "..") "..")] ...@@ -24,6 +24,17 @@ RELATIVE_LOCATIONS :== [".": take 5 (iterate ((</>) "..") "..")]
{ url :: String { url :: String
, task :: TaskWrapper , task :: TaskWrapper
} }
:: ServerOptions =
{ appName :: String
, appPath :: FilePath
, sdkPath :: Maybe FilePath
, serverPort :: Int
, keepalive :: Int
, webDirPaths :: Maybe [FilePath]
, storeOpt :: Maybe FilePath
, saplOpt :: Maybe FilePath
}
:: TaskWrapper = E.a: TaskWrapper (HTTPRequest -> Task a) & iTask a :: TaskWrapper = E.a: TaskWrapper (HTTPRequest -> Task a) & iTask a
...@@ -36,6 +47,16 @@ RELATIVE_LOCATIONS :== [".": take 5 (iterate ((</>) "..") "..")] ...@@ -36,6 +47,16 @@ RELATIVE_LOCATIONS :== [".": take 5 (iterate ((</>) "..") "..")]
*/ */
startEngine :: a !*World -> *World | Publishable a startEngine :: a !*World -> *World | Publishable a
/**
* Starts the task engine with options and a list of published task definitions.
*
* @param Tasks to start
* @param Options to use like port and server paths.
* @param The world
* @return The world
*/
startEngineWithOptions :: a ServerOptions !*World -> *World | Publishable a
/** /**
* Wraps a task together with a url to make it publishable by the engine * Wraps a task together with a url to make it publishable by the engine
*/ */
......
...@@ -31,10 +31,18 @@ from Sapl.Linker.LazyLinker import generateLoaderState, :: LoaderStateExt ...@@ -31,10 +31,18 @@ from Sapl.Linker.LazyLinker import generateLoaderState, :: LoaderStateExt
from Sapl.Linker.SaplLinkerShared import :: SkipSet from Sapl.Linker.SaplLinkerShared import :: SkipSet
from Sapl.Target.Flavour import :: Flavour, toFlavour from Sapl.Target.Flavour import :: Flavour, toFlavour
show :: ![String] !*World -> *World
show lines world
# (console,world) = stdio world
# console = seqSt (\s c -> fwrites (s +++ "\n") c) lines console
# (_,world) = fclose console world
= world
startEngine :: a !*World -> *World | Publishable a startEngine :: a !*World -> *World | Publishable a
startEngine publishable world startEngine publishable world
# (opts,world) = getCommandLine world # (opts,world) = getCommandLine world
# (appName,world) = determineAppName world # (appName,world) = determineAppName world
# (appPath,world) = determineAppPath world
# (mbSDKPath,world) = determineSDKPath SEARCH_PATHS world # (mbSDKPath,world) = determineSDKPath SEARCH_PATHS world
// Show server name // Show server name
# world = show (infoline appName) world # world = show (infoline appName) world
...@@ -51,23 +59,18 @@ startEngine publishable world ...@@ -51,23 +59,18 @@ startEngine publishable world
| help = show instructions world | help = show instructions world
//Check sdkpath //Check sdkpath
# mbSDKPath = maybe mbSDKPath Just sdkOpt //Commandline SDK option overrides found paths # mbSDKPath = maybe mbSDKPath Just sdkOpt //Commandline SDK option overrides found paths
//Normal execution # options =
# world = show (running port) world { appName = appName
# iworld = createIWorld appName mbSDKPath webDirPaths storeOpt saplOpt world , appPath = appPath
# (res,iworld) = initJSCompilerState iworld , sdkPath = mbSDKPath
| res =:(Error _) , serverPort = port
= show ["Fatal error: " +++ fromError res] (destroyIWorld iworld) , keepalive = keepalive
// All persistent task instances should receive a reset event to continue their work , webDirPaths = webDirPaths
# iworld = queueAllPersistent iworld , storeOpt = storeOpt
//Run task server , saplOpt = saplOpt
# iworld = serve port (httpServer port keepalive (engine publishable) allUIChanges) }
[BackgroundTask removeOutdatedSessions = startEngineWithOptions publishable options world
,BackgroundTask updateClocks, BackgroundTask (processEvents MAX_EVENTS)] timeout iworld
= destroyIWorld iworld
where where
infoline :: !String -> [String]
infoline app = ["*** " +++ app +++ " HTTP server ***",""]
instructions :: [String] instructions :: [String]
instructions = instructions =
["Available commandline options:" ["Available commandline options:"
...@@ -81,8 +84,10 @@ where ...@@ -81,8 +84,10 @@ where
,"" ,""
] ]
running :: !Int -> [String] //running :: !Int -> [String]
running port = ["Running at http://localhost" +++ (if (port == 80) "/" (":" +++ toString port +++ "/"))] //running port = ["Running at http://localhost" +++ (if (port == 80) "/" (":" +++ toString port +++ "/"))]
infoline :: !String -> [String]
infoline app = ["*** " +++ app +++ " HTTP server ***",""]
boolOpt :: !String ![String] -> Bool boolOpt :: !String ![String] -> Bool
boolOpt key opts = isMember key opts boolOpt key opts = isMember key opts
...@@ -102,10 +107,27 @@ where ...@@ -102,10 +107,27 @@ where
stringOpt key [n,v:r] stringOpt key [n,v:r]
| n == key = Just v | n == key = Just v
= stringOpt key [v:r] = stringOpt key [v:r]
startEngineWithOptions :: a ServerOptions !*World -> *World | Publishable a
startEngineWithOptions publishable options=:{appName,sdkPath,serverPort,webDirPaths,keepalive,storeOpt,saplOpt} world
# world = show (running serverPort) world
# iworld = createIWorld appName sdkPath webDirPaths storeOpt saplOpt world
# (res,iworld) = initJSCompilerState iworld
| res =:(Error _) = show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
// All persistent task instances should receive a reset event to continue their work
# iworld = queueAllPersistent iworld
//Start task server
# iworld = serve serverPort (httpServer serverPort keepalive (engine publishable) allUIChanges)
[BackgroundTask removeOutdatedSessions
,BackgroundTask updateClocks, BackgroundTask (processEvents MAX_EVENTS)] timeout iworld
= destroyIWorld iworld
where
running :: !Int -> [String]
running port = ["Running at http://localhost" +++ (if (port == 80) "/" (":" +++ toString port +++ "/"))]
timeout :: !*IWorld -> (!Maybe Timeout,!*IWorld) timeout :: !*IWorld -> (!Maybe Timeout,!*IWorld)
timeout iworld = case 'SDS'.read taskEvents iworld of //Check if there are events in the queue timeout iworld = case 'SDS'.read taskEvents iworld of //Check if there are events in the queue
(Ok (Queue [] []),iworld) = (Just 100,iworld) //Empty queue, don't waste CPU, but refresh (Ok (Queue [] []),iworld) = (Just 10,iworld) //Empty queue, don't waste CPU, but refresh
(Ok _,iworld) = (Just 0,iworld) //There are still events, don't wait (Ok _,iworld) = (Just 0,iworld) //There are still events, don't wait
(Error _,iworld) = (Just 500,iworld) //Keep retrying, but not too fast (Error _,iworld) = (Just 500,iworld) //Keep retrying, but not too fast
......
...@@ -96,7 +96,7 @@ CLEAN_HOME_VAR :== "CLEAN_HOME" ...@@ -96,7 +96,7 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
:: *IOTaskInstance :: *IOTaskInstance
= ListenerInstance !ListenerInstanceOpts !*TCP_Listener = ListenerInstance !ListenerInstanceOpts !*TCP_Listener
| ConnectionInstance !ConnectionInstanceOpts !*TCP_DuplexChannel | ConnectionInstance !ConnectionInstanceOpts !*TCP_DuplexChannel
| BackgroundInstance !BackgroundTask | BackgroundInstance !BackgroundInstanceOpts !BackgroundTask
:: ListenerInstanceOpts = :: ListenerInstanceOpts =
{ taskId :: !TaskId //Reference to the task that created the listener { taskId :: !TaskId //Reference to the task that created the listener
...@@ -116,6 +116,13 @@ CLEAN_HOME_VAR :== "CLEAN_HOME" ...@@ -116,6 +116,13 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
:: ConnectionId :== Int :: ConnectionId :== Int
:: BackgroundInstanceOpts =
{ bgInstId :: !BackgroundTaskId
}
:: BackgroundTaskId :== Int
:: IOStates :== Map TaskId IOState :: IOStates :== Map TaskId IOState
:: IOState :: IOState
= IOActive !(Map ConnectionId (!Dynamic,!Bool)) = IOActive !(Map ConnectionId (!Dynamic,!Bool))
......
...@@ -8,7 +8,7 @@ from Internet.HTTP import :: HTTPRequest, :: HTTPResponse ...@@ -8,7 +8,7 @@ from Internet.HTTP import :: HTTPRequest, :: HTTPResponse
from System.Time import :: Timestamp from System.Time import :: Timestamp
from Data.Error import :: MaybeError from Data.Error import :: MaybeError
from iTasks.API.Core.Types import :: TaskId from iTasks.API.Core.Types import :: TaskId
from iTasks._Framework.IWorld import :: IWorld from iTasks._Framework.IWorld import :: IWorld, :: BackgroundTaskId
from iTasks._Framework.Task import :: ConnectionTask, :: BackgroundTask, :: TaskException from iTasks._Framework.Task import :: ConnectionTask, :: BackgroundTask, :: TaskException
//Core task server loop //Core task server loop
...@@ -19,3 +19,9 @@ addListener :: !TaskId !Int !Bool !ConnectionTask !*IWorld -> (!MaybeError TaskE ...@@ -19,3 +19,9 @@ addListener :: !TaskId !Int !Bool !ConnectionTask !*IWorld -> (!MaybeError TaskE
//Dynamically add a connection //Dynamically add a connection
addConnection :: !TaskId !String !Int !ConnectionTask !*IWorld -> (!MaybeError TaskException (),!*IWorld) addConnection :: !TaskId !String !Int !ConnectionTask !*IWorld -> (!MaybeError TaskException (),!*IWorld)
//Dynamically add a background task
addBackgroundTask :: !BackgroundTaskId !BackgroundTask !*IWorld -> (!MaybeError TaskException (),!*IWorld)
//Dynamically remove a background task
removeBackgroundTask :: !BackgroundTaskId !*IWorld -> (!MaybeError TaskException (),!*IWorld)
...@@ -19,7 +19,7 @@ from iTasks._Framework.TaskStore import queueRefresh ...@@ -19,7 +19,7 @@ from iTasks._Framework.TaskStore import queueRefresh
:: *IOTaskInstanceDuringSelect :: *IOTaskInstanceDuringSelect
= ListenerInstanceDS !ListenerInstanceOpts = ListenerInstanceDS !ListenerInstanceOpts
| ConnectionInstanceDS !ConnectionInstanceOpts !*TCP_SChannel | ConnectionInstanceDS !ConnectionInstanceOpts !*TCP_SChannel
| BackgroundInstanceDS !BackgroundTask | BackgroundInstanceDS !BackgroundInstanceOpts !BackgroundTask
serve :: !Int !ConnectionTask ![BackgroundTask] (*IWorld -> (!Maybe Timeout,!*IWorld)) *IWorld -> *IWorld serve :: !Int !ConnectionTask ![BackgroundTask] (*IWorld -> (!Maybe Timeout,!*IWorld)) *IWorld -> *IWorld
serve port ct bt determineTimeout iworld serve port ct bt determineTimeout iworld
...@@ -31,7 +31,7 @@ init port ct bt iworld=:{IWorld|ioTasks,world} ...@@ -31,7 +31,7 @@ init port ct bt iworld=:{IWorld|ioTasks,world}
| not success = abort ("Error: port "+++ toString port +++ " already in use.\n") | not success = abort ("Error: port "+++ toString port +++ " already in use.\n")
# opts = {ListenerInstanceOpts|taskId=TaskId 0 0, nextConnectionId=0, port=port, connectionTask=ct, removeOnClose = True} # opts = {ListenerInstanceOpts|taskId=TaskId 0 0, nextConnectionId=0, port=port, connectionTask=ct, removeOnClose = True}
# ioStates = 'DM'.fromList [(TaskId 0 0, IOActive 'DM'.newMap)] # ioStates = 'DM'.fromList [(TaskId 0 0, IOActive 'DM'.newMap)]
= {iworld & ioTasks = {done=[],todo=[ListenerInstance opts (fromJust mbListener):map BackgroundInstance bt]}, ioStates = ioStates, world = world} = {iworld & ioTasks = {done=[],todo=[ListenerInstance opts (fromJust mbListener):map (BackgroundInstance {bgInstId=0})bt]}, ioStates = ioStates, world = world}
loop :: !(*IWorld -> (!Maybe Timeout,!*IWorld)) !*IWorld -> *IWorld loop :: !(*IWorld -> (!Maybe Timeout,!*IWorld)) !*IWorld -> *IWorld
loop determineTimeout iworld loop determineTimeout iworld
...@@ -63,7 +63,7 @@ toSelectSet [i:is] ...@@ -63,7 +63,7 @@ toSelectSet [i:is]
= case i of = case i of
ListenerInstance opts l = ([l:ls],rs,[ListenerInstanceDS opts:is]) ListenerInstance opts l = ([l:ls],rs,[ListenerInstanceDS opts:is])
ConnectionInstance opts {rChannel,sChannel} = (ls,[rChannel:rs],[ConnectionInstanceDS opts sChannel:is]) ConnectionInstance opts {rChannel,sChannel} = (ls,[rChannel:rs],[ConnectionInstanceDS opts sChannel:is])
BackgroundInstance bt = (ls,rs,[BackgroundInstanceDS bt:is]) BackgroundInstance opts bt = (ls,rs,[BackgroundInstanceDS opts bt:is])
/* Restore the list of main loop instances. /* Restore the list of main loop instances.
In the same pass also update the indices in the select result to match the In the same pass also update the indices in the select result to match the
...@@ -99,9 +99,9 @@ where ...@@ -99,9 +99,9 @@ where
# (is,ch) = fromSelectSet` (i+1) numListeners numSeenListeners (numSeenReceivers+1) ls rs [(c,what):ch] is # (is,ch) = fromSelectSet` (i+1) numListeners numSeenListeners (numSeenReceivers+1) ls rs [(c,what):ch] is
= ([ConnectionInstance opts {rChannel=rChannel,sChannel=sChannel}:is],ch) = ([ConnectionInstance opts {rChannel=rChannel,sChannel=sChannel}:is],ch)
//Background tasks //Background tasks
fromSelectSet` i numListeners numSeenListeners numSeenReceivers ls rs ch [BackgroundInstanceDS bt:is] fromSelectSet` i numListeners numSeenListeners numSeenReceivers ls rs ch [BackgroundInstanceDS opts bt:is]
# (is,ch) = fromSelectSet` (i+1) numListeners numSeenListeners numSeenReceivers ls rs ch is # (is,ch) = fromSelectSet` (i+1) numListeners numSeenListeners numSeenReceivers ls rs ch is
= ([BackgroundInstance bt:is],ch) = ([BackgroundInstance opts bt:is],ch)
ulength [] = (0,[]) ulength [] = (0,[])
ulength [x:xs] ulength [x:xs]
...@@ -263,10 +263,10 @@ process i chList iworld=:{ioTasks={done,todo=[ConnectionInstance opts {rChannel, ...@@ -263,10 +263,10 @@ process i chList iworld=:{ioTasks={done,todo=[ConnectionInstance opts {rChannel,
# world = closeChannel sChannel world # world = closeChannel sChannel world
= process (i+1) chList {iworld & ioTasks={done=done,todo=todo}, ioStates = ioStates, world=world} = process (i+1) chList {iworld & ioTasks={done=done,todo=todo}, ioStates = ioStates, world=world}
process i chList iworld=:{ioTasks={done,todo=[BackgroundInstance bt=:(BackgroundTask eval):todo]}} process i chList iworld=:{ioTasks={done,todo=[BackgroundInstance opts bt=:(BackgroundTask eval):todo]}}
# (mbe,iworld=:{ioTasks={done,todo}}) = eval {iworld & ioTasks = {done=done,todo=todo}} # (mbe,iworld=:{ioTasks={done,todo}}) = eval {iworld & ioTasks = {done=done,todo=todo}}
| mbe =: (Error _) = abort (snd (fromError mbe)) //TODO Handle the error without an abort | mbe =: (Error _) = abort (snd (fromError mbe)) //TODO Handle the error without an abort
= process (i+1) chList {iworld & ioTasks={done=[BackgroundInstance bt:done],todo=todo}} = process (i+1) chList {iworld & ioTasks={done=[BackgroundInstance opts bt:done],todo=todo}}
process i chList iworld=:{ioTasks={done,todo=[t:todo]}} process i chList iworld=:{ioTasks={done,todo=[t:todo]}}
= process (i+1) chList {iworld & ioTasks={done=[t:done],todo=todo}} = process (i+1) chList {iworld & ioTasks={done=[t:done],todo=todo}}
...@@ -321,6 +321,24 @@ addConnection taskId=:(TaskId instanceNo _) host port connectionTask iworld=:{io ...@@ -321,6 +321,24 @@ addConnection taskId=:(TaskId instanceNo _) host port connectionTask iworld=:{io
Error e = 'DM'.put taskId (IOException e) ioStates Error e = 'DM'.put taskId (IOException e) ioStates
= (Ok (),{iworld & ioTasks = {done=done,todo=todo}, ioStates = ioStates, world = world}) = (Ok (),{iworld & ioTasks = {done=done,todo=todo}, ioStates = ioStates, world = world})
//Dynamically add a background task
addBackgroundTask :: !BackgroundTaskId !BackgroundTask !*IWorld -> (!MaybeError TaskException (),!*IWorld)
addBackgroundTask btid bt iworld=:{ioTasks={done,todo}}
# todo = todo ++ [BackgroundInstance {BackgroundInstanceOpts|bgInstId=btid} bt]
= (Ok (), {iworld & ioTasks={done=done, todo=todo}})
//Dynamically remove a background task
removeBackgroundTask :: !BackgroundTaskId !*IWorld -> (!MaybeError TaskException (),!*IWorld)
removeBackgroundTask btid iworld=:{ioTasks={done,todo}}
//We filter the tasks and use the boolean state to hold whether a task was dropped
# (r, todo) = foldr (\e (b, l)->let (b`, e`)=drop e in (b` || b, if b` l [e`:l])) (False, []) todo
# iworld = {iworld & ioTasks={done=done, todo=todo}}
| not r = (Error (exception "No backgroundtask with that id"), iworld)
= (Ok (), iworld)
where
drop a=:(BackgroundInstance {bgInstId} _) = (bgInstId == btid, a)
drop a = (False, a)
checkSelect :: !Int ![(!Int,!SelectResult)] -> (!Maybe SelectResult,![(!Int,!SelectResult)]) checkSelect :: !Int ![(!Int,!SelectResult)] -> (!Maybe SelectResult,![(!Int,!SelectResult)])
checkSelect i chList =:[(who,what):ws] | (i == who) = (Just what,ws) checkSelect i chList =:[(who,what):ws] | (i == who) = (Just what,ws)
checkSelect i chList = (Nothing,chList) checkSelect i chList = (Nothing,chList)
...@@ -334,6 +352,6 @@ halt iworld=:{ioTasks={todo=[ConnectionInstance _ {rChannel,sChannel}:todo],done ...@@ -334,6 +352,6 @@ halt iworld=:{ioTasks={todo=[ConnectionInstance _ {rChannel,sChannel}:todo],done
# world = closeRChannel rChannel world # world = closeRChannel rChannel world
# world = closeChannel sChannel world # world = closeChannel sChannel world
= halt {iworld & ioTasks = {todo=todo,done=done}} = halt {iworld & ioTasks = {todo=todo,done=done}}
halt iworld=:{ioTasks={todo=[BackgroundInstance _ :todo],done},world} halt iworld=:{ioTasks={todo=[BackgroundInstance _ _ :todo],done},world}
= halt {iworld & ioTasks= {todo=todo,done=done}} = halt {iworld & ioTasks= {todo=todo,done=done}}
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