Commit 8e3d056a authored by Bas Lijnse's avatar Bas Lijnse

Changed task output queue to allow server-side exception information to be...

Changed task output queue to allow server-side exception information to be sent properly to the client framework.
parent cc2e8167
......@@ -135,7 +135,7 @@ startEngineWithOptions initFun publishable world
# iworld = serve [] (tcpTasks options.serverPort options.keepaliveTime) engineTasks timeout iworld
= destroyIWorld iworld
where
tcpTasks serverPort keepaliveTime = [(serverPort,httpServer serverPort keepaliveTime (engineWebService publishable) allUIChanges)]
tcpTasks serverPort keepaliveTime = [(serverPort,httpServer serverPort keepaliveTime (engineWebService publishable) taskOutput)]
engineTasks =
[BackgroundTask updateClock
,BackgroundTask (processEvents MAX_EVENTS)
......@@ -169,16 +169,9 @@ show lines world
# console = seqSt (\s c -> fwrites (s +++ "\n") c) lines console
# (_,world) = fclose console world
= world
/*
timeout :: !*IWorld -> (!Maybe Timeout,!*IWorld)
timeout iworld = case 'SDS'.read taskEvents iworld of //Check if there are events in the queue
(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
(Error _,iworld) = (Just 500,iworld) //Keep retrying, but not too fast
*/
// The iTasks engine consist of a set of HTTP WebService
engineWebService :: publish -> [WebService (Map InstanceNo (Queue UIChange)) (Map InstanceNo (Queue UIChange))] | Publishable publish
engineWebService :: publish -> [WebService (Map InstanceNo TaskOutput) (Map InstanceNo TaskOutput)] | Publishable publish
engineWebService publishable = [taskUIService published, documentService, sdsService, staticResourceService [url \\ {PublishedTask|url} <- published]]
where
published = publishAll publishable
......
......@@ -51,7 +51,7 @@ where
notSelf ownPid {TaskInstance|instanceNo} = (TaskId instanceNo 0) <> ownPid
notSelf ownPid _ = False
isActive {TaskInstance|value} = value === None || value === Unstable
isActive {TaskInstance|value} = value === Unstable
mkRow {TaskInstance|instanceNo,attributes,listId} =
{WorklistRow
......
......@@ -240,10 +240,9 @@ where
, firstWorkedOn = fmap timestampToGmDateTime p.InstanceProgress.firstEvent
, lastWorkedOn = fmap timestampToGmDateTime p.InstanceProgress.lastEvent
, taskStatus = case p.InstanceProgress.value of
None -> "No results so far..."
Unstable -> "In progres..."
Stable -> "Task done"
Exception -> "Something went wrong"
Unstable -> "In progres..."
Stable -> "Task done"
(Exception _) -> "Something went wrong"
}
toView (_,[{TaskListItem|attributes}:_]) =
{ assignedTo = mkAssignedTo attributes
......
......@@ -101,17 +101,17 @@ newWorld = undef
getUIUpdates :: !*IWorld -> (!Maybe [(InstanceNo, [String])], *IWorld)
getUIUpdates iworld
= case 'SDS'.read allUIChanges iworld of
(Ok uiChanges,iworld)
= case 'Data.Map'.toList uiChanges of
= case 'SDS'.read taskOutput iworld of
(Ok output,iworld)
= case 'Data.Map'.toList output of
[] = (Nothing,iworld)
changes
# (_,iworld) = 'SDS'.write 'Data.Map'.newMap allUIChanges iworld
= (Just (map getUpdates changes), iworld)
output
# (_,iworld) = 'SDS'.write 'Data.Map'.newMap taskOutput iworld
= (Just (map getUpdates output), iworld)
(_,iworld)
= (Nothing, iworld)
where
getUpdates (instanceNo,upds) = (instanceNo, [toString (encodeUIChanges (toList upds))])
getUpdates (instanceNo,upds) = (instanceNo, [toString (encodeUIChanges [c \\ TOUIChange c <- toList upds])])
toList q = case 'DQ'.dequeue q of //TODO SHOULD BE IN Data.Queue
(Nothing,q) = []
(Just x,q) = [x:toList q]
......
......@@ -97,8 +97,8 @@ stopOnStable iworld=:{IWorld|shutdown}
= (Ok (), {IWorld|iworld & shutdown = shutdown})
Error e = (Error e, iworld)
where
allStable instances = all (\v -> v =: Stable || v =: Exception) (values instances)
exceptionOccurred instances = any (\v -> v =: Exception) (values instances)
allStable instances = all (\v -> v =: Stable || v =: (Exception _)) (values instances)
exceptionOccurred instances = any (\v -> v =: (Exception _)) (values instances)
values instances = [value \\ (_,_,Just {InstanceProgress|value},_) <- instances]
......@@ -23,7 +23,7 @@ from GenEq import generic gEq
from iTasks.SDS.Definition import :: SDS
sdsService :: WebService (Map InstanceNo (Queue UIChange)) (Map InstanceNo (Queue UIChange))
sdsService :: WebService a a
readRemoteSDS :: !JSONNode !String !*IWorld -> *(!MaybeErrorString JSONNode, !*IWorld)
writeRemoteSDS :: !JSONNode !JSONNode !String !*IWorld -> *(!MaybeErrorString (), !*IWorld)
......
......@@ -23,7 +23,7 @@ import Text.JSON, Text.URI
import StdMisc, graph_to_sapl_string
import Data.Queue, Data.Functor
sdsService :: WebService (Map InstanceNo (Queue UIChange)) (Map InstanceNo (Queue UIChange))
sdsService :: WebService a a
sdsService = { urlMatchPred = matchFun
, completeRequest = True
, onNewReq = reqFun
......@@ -38,7 +38,7 @@ where
["","sds",_] = True
= False
reqFun :: !HTTPRequest (Map InstanceNo (Queue UIChange)) !*IWorld -> *(!HTTPResponse, !Maybe ConnectionState, !Maybe (Map InstanceNo (Queue UIChange)), !*IWorld)
reqFun :: !HTTPRequest a !*IWorld -> *(!HTTPResponse, !Maybe ConnectionState, !Maybe a, !*IWorld)
reqFun req _ iworld | hasParam "client_session_id" req
= abort "Shareds on clients are not supported yet"
reqFun req _ iworld=:{exposedShares} | hasParam "focus" req
......@@ -76,13 +76,13 @@ where
plainResponse string
= {okResponse & rsp_headers = [("Content-Type","text/plain")], rsp_data = string}
dataFun :: !HTTPRequest (Map InstanceNo (Queue UIChange)) !String !ConnectionState !*IWorld -> (![{#Char}], !Bool, !ConnectionState,!Maybe (Map InstanceNo (Queue UIChange)), !*IWorld)
dataFun :: !HTTPRequest a !String !ConnectionState !*IWorld -> (![{#Char}], !Bool, !ConnectionState,!Maybe a, !*IWorld)
dataFun req _ data instanceNo iworld = ([], True, instanceNo, Nothing, iworld)
onShareChange _ _ s iworld = ([], True, s, Nothing, iworld)
onTick _ _ instanceNo iworld = ([], True, instanceNo, Nothing, iworld)
disconnectFun :: !HTTPRequest (Map InstanceNo (Queue UIChange)) !ConnectionState !*IWorld -> (!Maybe (Map InstanceNo (Queue UIChange)), !*IWorld)
disconnectFun :: !HTTPRequest a !ConnectionState !*IWorld -> (!Maybe a, !*IWorld)
disconnectFun _ _ _ iworld = (Nothing,iworld)
readRemoteSDS :: !JSONNode !String !*IWorld -> *(!MaybeErrorString JSONNode, !*IWorld)
......
......@@ -65,7 +65,6 @@ processEvents max iworld
(Ok taskValue,iworld)
= processEvents (max - 1) iworld
(Error msg,iworld=:{IWorld|world})
# world = show ["WARNING: "+++ msg] world
= (Ok (),{IWorld|iworld & world = world})
//Evaluate a single task instance
......@@ -77,22 +76,19 @@ evalTaskInstance instanceNo event iworld
where
evalTaskInstance` instanceNo event iworld=:{clock,current}
# (constants, iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceConstants) iworld
| isError constants = ((\(Error (e,msg)) -> Error msg) constants, iworld)
| isError constants = exitWithException instanceNo ((\(Error (e,msg)) -> msg) constants) iworld
# constants=:{InstanceConstants|session,listId} = fromOk constants
# (oldReduct, iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceReduct) iworld
| isError oldReduct = ((\(Error (e,msg)) -> Error msg) oldReduct, iworld)
| isError oldReduct = exitWithException instanceNo ((\(Error (e,msg)) -> msg) oldReduct) iworld
# oldReduct=:{TIReduct|task=Task eval,tree,nextTaskNo=curNextTaskNo,nextTaskTime,tasks,tonicRedOpts} = fromOk oldReduct
# (oldProgress,iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceProgress) iworld
| isError oldProgress = ((\(Error (e,msg)) -> Error msg) oldProgress, iworld)
| isError oldProgress = exitWithException instanceNo ((\(Error (e,msg)) -> msg) oldProgress) iworld
# oldProgress=:{InstanceProgress|value,attachedTo} = fromOk oldProgress
//Check exeption
| value === Exception
# (oldValue, iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceValue) iworld
= case oldValue of
(Error (e,msg)) = (Error msg, iworld)
(Ok (TIException e msg)) = (Error msg, iworld)
(Ok _) = (Error "Exception no longer available", iworld)
//Eval instance
| value =: (Exception _)
# (Exception description) = value
= exitWithException instanceNo description iworld
//Eval instance
# (currentSession,currentAttachment) = case (session,attachedTo) of
(True,_) = (Just instanceNo,[])
(_,[]) = (Nothing,[])
......@@ -120,7 +116,8 @@ where
(Ok (),iworld) //Only update progress when something changed
('SDS'.modify (\p -> ((),updateProgress clock newResult p)) (sdsFocus instanceNo taskInstanceProgress) iworld)
= case mbErr of
Error (e,msg) = (Error msg,iworld)
Error (e,description)
= exitWithException instanceNo description iworld
Ok _
//Store updated reduct
# (nextTaskNo,iworld) = getNextTaskNo iworld
......@@ -133,7 +130,7 @@ where
(ExceptionResult (e,str)) = TIException e str
# (mbErr,iworld) = if deleted (Ok (),iworld) ('SDS'.write newValue (sdsFocus instanceNo taskInstanceValue) iworld)
= case mbErr of
Error (e,msg) = (Error msg,iworld)
Error (e,description) = exitWithException instanceNo description iworld
Ok _
= case newResult of
(ValueResult value _ change _)
......@@ -145,8 +142,12 @@ where
change
# iworld = queueUIChange instanceNo change iworld
= (Ok value, iworld)
(ExceptionResult (e,msg))
= (Error msg, iworld)
(ExceptionResult (e,description))
= exitWithException instanceNo description iworld
exitWithException instanceNo description iworld
# iworld = queueException instanceNo description iworld
= (Error description, iworld)
getNextTaskNo iworld=:{IWorld|current={TaskEvalState|nextTaskNo}} = (nextTaskNo,iworld)
......@@ -159,15 +160,12 @@ where
,lastEvent = Just now
}
= case result of
(ExceptionResult _) = {InstanceProgress|progress & value = Exception}
(ValueResult (Value _ stable) _ _ _)
= {InstanceProgress|progress & value = if stable Stable Unstable}
(ValueResult _ _ _ _)
= {InstanceProgress|progress & value = None}
_ = {InstanceProgress|progress & value = None}
(ExceptionResult (_,msg)) = {InstanceProgress|progress & value = Exception msg}
(ValueResult (Value _ stable) _ _ _) = {InstanceProgress|progress & value = if stable Stable Unstable}
_ = {InstanceProgress|progress & value = Unstable }
mbResetUIState instanceNo ResetEvent iworld
# (_,iworld) = 'SDS'.write 'DQ'.newQueue (sdsFocus instanceNo taskInstanceUIChanges) iworld
# (_,iworld) = 'SDS'.write 'DQ'.newQueue (sdsFocus instanceNo taskInstanceOutput) iworld
//Remove all js compiler state for this instance
# iworld=:{jsCompilerState=jsCompilerState} = iworld
# jsCompilerState = fmap (\state -> {state & skipMap = 'DM'.del instanceNo state.skipMap}) jsCompilerState
......
......@@ -24,7 +24,7 @@ addListener :: !TaskId !Int !Bool !ConnectionTask !*IWorld -> (!MaybeError TaskE
addConnection :: !TaskId !String !Int !ConnectionTask !*IWorld -> (!MaybeError TaskException Dynamic,!*IWorld)
//Dynamically add an external process
addExternalProc :: !TaskId !FilePath ![String] !(Maybe FilePath) !ExternalProcessTask (!Maybe ProcessPtyOptions) !IWorld -> (!MaybeError TaskException Dynamic, !*IWorld)
addExternalProc :: !TaskId !FilePath ![String] !(Maybe FilePath) !ExternalProcessTask (Maybe ProcessPtyOptions) !IWorld -> (!MaybeError TaskException Dynamic, !*IWorld)
//Dynamically add a background task
addBackgroundTask :: !BackgroundTask !*IWorld -> (!MaybeError TaskException BackgroundTaskId,!*IWorld)
......
......@@ -547,7 +547,7 @@ where
# opts = {ConnectionInstanceOpts|taskId = taskId, connectionId = 0, remoteHost = ip, connectionTask = connectionTask, removeOnClose = False}
= ConnectionInstance opts channel
addExternalProc :: !TaskId !FilePath ![String] !(Maybe FilePath) !ExternalProcessTask (!Maybe 'Process'.ProcessPtyOptions) !IWorld -> (!MaybeError TaskException Dynamic, !*IWorld)
addExternalProc :: !TaskId !FilePath ![String] !(Maybe FilePath) !ExternalProcessTask (Maybe 'Process'.ProcessPtyOptions) !IWorld -> (!MaybeError TaskException Dynamic, !*IWorld)
addExternalProc taskId cmd args dir extProcTask=:(ExternalProcessTask handlers sds) mopts iworld
= addIOTask taskId sds init externalProcessIOOps onInitHandler mkIOTaskInstance iworld
where
......
......@@ -26,6 +26,7 @@ from System.Time import :: Timestamp
, includeProgress :: !Bool
, includeAttributes :: !Bool
}
:: InstanceData :== (!InstanceNo,!Maybe InstanceConstants,!Maybe InstanceProgress,!Maybe TaskAttributes)
derive class iTask InstanceFilter
......@@ -69,7 +70,6 @@ taskInstanceReduct :: RWShared InstanceNo TIReduct TIReduct
taskInstanceValue :: RWShared InstanceNo TIValue TIValue
taskInstanceShares :: RWShared InstanceNo (Map TaskId JSONNode) (Map TaskId JSONNode)
//Filtered views on evaluation state of instances:
//Shared source
......@@ -91,8 +91,15 @@ parallelTaskList :: RWShared (!TaskId,!TaskId,!TaskListFilter
//When task instances are evaluated, their output consists of instructions to modify the user interface
//of that instance to reflect the instance's new state
allUIChanges :: RWShared () (Map InstanceNo (Queue UIChange)) (Map InstanceNo (Queue UIChange))
taskInstanceUIChanges :: RWShared InstanceNo (Queue UIChange) (Queue UIChange)
:: TaskOutputMessage
= TOUIChange !UIChange
| TOException !String
| TODetach !InstanceNo
:: TaskOutput :== Queue TaskOutputMessage
taskOutput :: RWShared () (Map InstanceNo TaskOutput) (Map InstanceNo TaskOutput)
taskInstanceOutput :: RWShared InstanceNo TaskOutput TaskOutput
//=== Access functions: ===
......@@ -151,13 +158,17 @@ queueRefresh :: ![(!TaskId, !String)] !*IWorld -> *IWorld
dequeueEvent :: !*IWorld -> (!Maybe (InstanceNo,Event),!*IWorld)
/**
* Queue task output
* Queue ui change task output
*/
queueUIChange :: !InstanceNo !UIChange !*IWorld -> *IWorld
/**
* Convenience function that queues multiple changes at once
*/
queueUIChanges :: !InstanceNo ![UIChange] !*IWorld -> *IWorld
/**
* Queue exception change task output
*/
queueException :: !InstanceNo !String !*IWorld -> *IWorld
/**
* When a new viewport is attached to an instance, all events and output are removed
......
......@@ -30,10 +30,10 @@ from Data.Queue import :: Queue(..)
from Control.Applicative import class Alternative(<|>), instance Alternative Maybe, instance Applicative Maybe
//Derives required for storage of UI definitions
derive JSONEncode TaskResult, TaskEvalInfo, TIValue, ParallelTaskState, ParallelTaskChange, TIUIState
derive JSONEncode TaskOutputMessage, TaskResult, TaskEvalInfo, TIValue, ParallelTaskState, ParallelTaskChange, TIUIState
derive JSONEncode Queue, Event, Set
derive JSONDecode TaskResult, TaskEvalInfo, TIValue, ParallelTaskState, ParallelTaskChange, TIUIState
derive JSONDecode TaskOutputMessage, TaskResult, TaskEvalInfo, TIValue, ParallelTaskState, ParallelTaskChange, TIUIState
derive JSONDecode Queue, Event, Set
derive gDefault TIMeta
......@@ -47,7 +47,7 @@ rawTaskNoCounter = storeShare NS_TASK_INSTANCES False InJSONFile (Just 1)
rawInstanceIO = storeShare NS_TASK_INSTANCES False InMemory (Just 'DM'.newMap)
rawInstanceEvents = storeShare NS_TASK_INSTANCES False InMemory (Just 'DQ'.newQueue)
rawInstanceUIChanges = storeShare NS_TASK_INSTANCES False InMemory (Just 'DM'.newMap)
rawInstanceOutput = storeShare NS_TASK_INSTANCES False InMemory (Just 'DM'.newMap)
rawInstanceReduct = storeShare NS_TASK_INSTANCES True InDynamicFile Nothing
rawInstanceValue = storeShare NS_TASK_INSTANCES True InDynamicFile Nothing
......@@ -89,18 +89,22 @@ taskInstanceValue = sdsTranslate "taskInstanceValue" (\t -> t +++> "-value") raw
taskInstanceShares :: RWShared InstanceNo (Map TaskId JSONNode) (Map TaskId JSONNode)
taskInstanceShares = sdsTranslate "taskInstanceShares" (\t -> t +++> "-shares") rawInstanceShares
allUIChanges :: RWShared () (Map InstanceNo (Queue UIChange)) (Map InstanceNo (Queue UIChange))
allUIChanges = sdsFocus "allUIChanges" rawInstanceUIChanges
:: TaskOutputMessage
= TOUIChange !UIChange
| TOException !String
| TODetach !InstanceNo
taskInstanceUIChanges :: RWShared InstanceNo (Queue UIChange) (Queue UIChange)
taskInstanceUIChanges = sdsLens "taskInstanceUIChanges" (const ()) (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) allUIChanges
where
read instanceNo uis = case 'DM'.get instanceNo uis of
Just ui = Ok ui
Nothing = Ok 'DQ'.newQueue
:: TaskOutput :== Queue TaskOutputMessage
write instanceNo uis ui = Ok (Just ('DM'.put instanceNo ui uis))
notify instanceNo _ = (==) instanceNo
taskOutput :: RWShared () (Map InstanceNo TaskOutput) (Map InstanceNo TaskOutput)
taskOutput = sdsFocus "taskOutput" rawInstanceOutput
taskInstanceOutput :: RWShared InstanceNo TaskOutput TaskOutput
taskInstanceOutput = sdsLens "taskInstanceOutput" (const ()) (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) taskOutput
where
read instanceNo outputs = Ok (fromMaybe 'DQ'.newQueue ('DM'.get instanceNo outputs))
write instanceNo outputs output = Ok (Just ('DM'.put instanceNo output outputs))
notify instanceNo _ = (==) instanceNo
//Task instance parallel lists
taskInstanceParallelTaskLists :: RWShared InstanceNo (Map TaskId [ParallelTaskState]) (Map TaskId [ParallelTaskState])
......@@ -129,7 +133,7 @@ newDocumentId iworld=:{IWorld|random}
createClientTaskInstance :: !(Task a) !String !InstanceNo !*IWorld -> *(!MaybeError TaskException TaskId, !*IWorld) | iTask a
createClientTaskInstance task sessionId instanceNo iworld=:{options={appVersion},current={taskTime},clock}
//Create the initial instance data in the store
# progress = {InstanceProgress|value=None,instanceKey="client",attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# progress = {InstanceProgress|value=Unstable,instanceKey="client",attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# constants = {InstanceConstants|session=True,listId=TaskId 0 0,build=appVersion,issuedAt=clock}
= 'SDS'.write (instanceNo, Just constants,Just progress,Just defaultValue) (sdsFocus instanceNo taskInstance) iworld
`b` \iworld -> 'SDS'.write (createReduct defaultTonicOpts instanceNo task taskTime) (sdsFocus instanceNo taskInstanceReduct) iworld
......@@ -142,7 +146,7 @@ createTaskInstance task iworld=:{options={appVersion,autoLayout},current={taskTi
# (mbInstanceNo,iworld) = newInstanceNo iworld
# instanceNo = fromOk mbInstanceNo
# (instanceKey,iworld) = newInstanceKey iworld
# progress = {InstanceProgress|value=None,instanceKey=instanceKey,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# progress = {InstanceProgress|value=Unstable,instanceKey=instanceKey,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# constants = {InstanceConstants|session=True,listId=TaskId 0 0,build=appVersion,issuedAt=clock}
= 'SDS'.write (instanceNo, Just constants,Just progress,Just defaultValue) (sdsFocus instanceNo taskInstance) iworld
`b` \iworld -> 'SDS'.write (createReduct defaultTonicOpts instanceNo task taskTime) (sdsFocus instanceNo taskInstanceReduct) iworld
......@@ -157,7 +161,7 @@ createDetachedTaskInstance :: !(Task a) !Bool !TaskEvalOpts !InstanceNo !TaskAtt
createDetachedTaskInstance task isTopLevel evalOpts instanceNo attributes listId refreshImmediate iworld=:{options={appVersion,autoLayout},current={taskTime},clock}
# task = if autoLayout (tune (ApplyLayout defaultSessionLayout) task) task
# (instanceKey,iworld) = newInstanceKey iworld
# progress = {InstanceProgress|value=None,instanceKey=instanceKey,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# progress = {InstanceProgress|value=Unstable,instanceKey=instanceKey,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# constants = {InstanceConstants|session=False,listId=listId,build=appVersion,issuedAt=clock}
= 'SDS'.write (instanceNo,Just constants,Just progress,Just attributes) (sdsFocus instanceNo taskInstance) iworld
`b` \iworld -> 'SDS'.write (createReduct (if isTopLevel defaultTonicOpts evalOpts.tonicOpts) instanceNo task taskTime) (sdsFocus instanceNo taskInstanceReduct) iworld
......@@ -517,16 +521,21 @@ where
queueUIChange :: !InstanceNo !UIChange !*IWorld -> *IWorld
queueUIChange instanceNo change iworld
# (_,iworld) = 'SDS'.modify (\q -> ((),'DQ'.enqueue change q)) (sdsFocus instanceNo taskInstanceUIChanges) iworld
# (_,iworld) = 'SDS'.modify (\q -> ((),'DQ'.enqueue (TOUIChange change) q)) (sdsFocus instanceNo taskInstanceOutput) iworld
= iworld
queueUIChanges :: !InstanceNo ![UIChange] !*IWorld -> *IWorld
queueUIChanges instanceNo changes iworld
# (_,iworld) = 'SDS'.modify (\q -> ((),enqueueAll changes q)) (sdsFocus instanceNo taskInstanceUIChanges) iworld
# (_,iworld) = 'SDS'.modify (\q -> ((),enqueueAll changes q)) (sdsFocus instanceNo taskInstanceOutput) iworld
= iworld
where
enqueueAll [] q = q
enqueueAll [x:xs] q = enqueueAll xs ('DQ'.enqueue x q)
enqueueAll [x:xs] q = enqueueAll xs ('DQ'.enqueue (TOUIChange x) q)
queueException :: !InstanceNo !String !*IWorld -> *IWorld
queueException instanceNo description iworld
# (_,iworld) = 'SDS'.modify (\q -> ((),'DQ'.enqueue (TOException description) q)) (sdsFocus instanceNo taskInstanceOutput) iworld
= iworld
attachViewport :: !InstanceNo !*IWorld -> *IWorld
attachViewport instanceNo iworld
......
......@@ -8,6 +8,7 @@ from iTasks.Engine import :: PublishedTask
from iTasks.Internal.IWorld import :: IWorld
from iTasks.Internal.Task import :: Task, :: ConnectionTask
from iTasks.Internal.TaskState import :: TIUIState
from iTasks.Internal.TaskStore import :: TaskOutput, :: TaskOutputMessage
from iTasks.Internal.SDS import :: SDS, :: RWShared
from iTasks.UI.Definition import :: UIChange
from iTasks.WF.Definition import :: InstanceNo
......@@ -41,9 +42,9 @@ from Data.Map import :: Map
httpServer :: !Int !Int ![WebService r w] (RWShared () r w) -> ConnectionTask | TC r & TC w
:: ChangeQueues :== Map InstanceNo (Queue UIChange)
:: OutputQueues :== Map InstanceNo TaskOutput
taskUIService :: ![PublishedTask] -> WebService ChangeQueues ChangeQueues
taskUIService :: ![PublishedTask] -> WebService OutputQueues OutputQueues
documentService :: WebService r w
staticResourceService :: [String] -> WebService r w
......@@ -254,7 +254,7 @@ where
:: ChangeQueues :== Map InstanceNo (Queue UIChange)
taskUIService :: ![PublishedTask] -> WebService ChangeQueues ChangeQueues
taskUIService :: ![PublishedTask] -> WebService OutputQueues OutputQueues
taskUIService taskUrls = { urlMatchPred = matchFun [url \\ {PublishedTask|url} <-taskUrls]
, completeRequest = True
, onNewReq = reqFun taskUrls
......@@ -375,15 +375,20 @@ where
onTick req output (clientname,state,instances) iworld
//Check keys
# (instances,iworld) = verifyKeys instances iworld
//Check for UI updates for all attached instances
# (changes, output) = dequeueOutput (map fst instances) output
= case changes of //Ignore empty updates
//Check for output for all attached instances
# (messages, output) = dequeueOutput (map fst instances) output
= case messages of //Ignore empty updates
[] = ([],False,(clientname,state,instances),Nothing,iworld)
changes
# msgs =
[wsockTextMsg (toString (JSONArray [JSONInt 0,JSONString "ui-change"
,JSONObject [("instanceNo",JSONInt instanceNo),("change",encodeUIChange change)]])) \\ (instanceNo,change) <- changes]
= (flatten msgs,False, (clientname,state,instances),Just output,iworld)
messages
# json = [wsockTextMsg (toString (jsonMessage message)) \\ message <- messages]
= (flatten json,False, (clientname,state,instances), Just output, iworld)
jsonMessage (instanceNo, TOUIChange change)
= JSONArray [JSONInt 0,JSONString "ui-change"
,JSONObject [("instanceNo",JSONInt instanceNo),("change",encodeUIChange change)]]
jsonMessage (instanceNo, TOException description)
=JSONArray [JSONInt 0,JSONString "exception"
,JSONObject [("instanceNo",JSONInt instanceNo),("description",JSONString description)]]
disconnectFun _ _ (clientname,state,instances) iworld = (Nothing, snd (updateInstanceDisconnect (map fst instances) iworld))
disconnectFun _ _ _ iworld = (Nothing, iworld)
......@@ -394,7 +399,7 @@ where
uiUrl matchUrl = (if (endsWith "/" matchUrl) matchUrl (matchUrl +++ "/")) +++ "gui-wsock"
dequeueOutput :: ![InstanceNo] !(Map InstanceNo (Queue UIChange)) -> (![(!InstanceNo,!UIChange)],!Map InstanceNo (Queue UIChange))
dequeueOutput :: ![InstanceNo] !(Map InstanceNo TaskOutput) -> (![(!InstanceNo,!TaskOutputMessage)],!Map InstanceNo TaskOutput)
dequeueOutput [] states = ([],states)
dequeueOutput [i:is] states
# (output,states) = dequeueOutput is states
......@@ -427,6 +432,7 @@ where
where
format (instanceNo,change) = "data: {\"instance\":" +++toString instanceNo+++",\"change\":" +++ toString (encodeUIChange change) +++ "}\n\n"
//TODO: The upload and download mechanism used here is inherently insecure!!!
// A smarter scheme that checks up and downloads, based on the current session/task is needed to prevent
// unauthorized downloading of documents and DDOS uploading.
......
......@@ -767,7 +767,7 @@ where
# progress = {InstanceProgress|progress & instanceKey = newKey, attachedTo = [taskId:attachmentChain]}
# (_,iworld) = write progress (sdsFocus instanceNo taskInstanceProgress) iworld
//Clear all input and output of that instance
# (_,iworld) = write 'DQ'.newQueue (sdsFocus instanceNo taskInstanceUIChanges) iworld
# (_,iworld) = write 'DQ'.newQueue (sdsFocus instanceNo taskInstanceOutput) iworld
# (_,iworld) = modify (\('DQ'.Queue a b) -> ((),'DQ'.Queue [(i,e) \\(i,e)<- a| i <> instanceNo][(i,e) \\(i,e)<- b| i <> instanceNo])) taskEvents iworld
= eval event evalOpts (TCAttach taskId ts (ASAttached (value =: Stable)) build newKey) iworld
......@@ -777,11 +777,11 @@ where
//Determine state of the instance
# curStatus = case progress of
(Ok progress=:{InstanceProgress|attachedTo=[attachedId:_],value})
| build <> appVersion = ASIncompatible
| value =: Exception = ASExcepted
| attachedId <> taskId = ASInUse attachedId
= ASAttached (value =: Stable)
_ = ASDeleted
| build <> appVersion = ASIncompatible
| value =: (Exception _) = ASExcepted
| attachedId <> taskId = ASInUse attachedId
= ASAttached (value =: Stable)
_ = ASDeleted
//Determine UI change
# change = determineUIChange event curStatus prevStatus instanceNo instanceKey
# stable = (curStatus =: ASDeleted) || (curStatus =: ASExcepted)
......
......@@ -95,10 +95,9 @@ instance toInstanceNo TaskId
}
:: ValueStatus
= None
| Unstable
= Unstable
| Stable
| Exception
| Exception !String
//The iTask context restriction contains all generic functions that need to
//be available for a type to be used in tasks
......
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