Commit 4c7d401d authored by Bas Lijnse's avatar Bas Lijnse

- Added event handling to task service.

- Renamed *userUpdates functions in TSt to *Events functions, naming was confusing with TUIUpdates and all.

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@1109 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 1a026af0
......@@ -122,10 +122,10 @@ group label description procFun parseFun initState initTasks groupActions = mkGr
where
execInGroup tst=:{taskNr,request}
# grTaskNr = drop 1 taskNr // get taskNr of group-task
# (updates,tst) = getChildrenUpdatesFor grTaskNr tst
# (events,tst) = getEventsFor (taskNrToString grTaskNr) True tst
# (pst,tst) = loadPSt grTaskNr tst
# gAction = case parseString (http_getValue "_group" updates "") of
Nothing = parseString (http_getValue "menuAndGroup" updates "")
# gAction = case parseString (http_getValue "_group" events "") of
Nothing = parseString (http_getValue "menuAndGroup" events "")
res = res
# (gActionStop,mbFocus,pst)
= case gAction of
......@@ -300,7 +300,7 @@ where
= (result,{TSt|tst & tree = node})
createOrEvaluateTaskInstance :: !(Maybe TaskParallelType) !(Task a) !*TSt -> (!TaskResult a, !TaskTree, !*TSt) | iTask a
createOrEvaluateTaskInstance mbpartype task tst=:{TSt|taskNr,updates}
createOrEvaluateTaskInstance mbpartype task tst=:{TSt|taskNr,events}
//Try to load the stored process for this subtask
# taskId = taskNrToString taskNr
# (mbProc,tst) = getProcess taskId tst
......@@ -320,7 +320,7 @@ createOrEvaluateTaskInstance mbpartype task tst=:{TSt|taskNr,updates}
# user = proc.Process.properties.managerProperties.ManagerProperties.worker
# tst = addSubTaskWorker taskId user mbpartype tst
// -> TSt in subprocess
# (result,tree,tst) = evaluateTaskInstance proc updates Nothing False False tst
# (result,tree,tst) = evaluateTaskInstance proc events Nothing False False tst
// <- TSt back to current process
//Add parallel type after the new proc is evaluated
= case result of
......
......@@ -76,11 +76,11 @@ jsonQuery :: !String !JSONNode -> Maybe a | JSONDecode{|*|} a
* for each type you want to encode in JSON format.
*/
generic JSONEncode t :: t -> [JSONNode]
derive JSONEncode Int, Real, Char, Bool, String, UNIT, PAIR, EITHER, FIELD, CONS, OBJECT, [], (,), {}, {!}, Maybe, JSONNode
derive JSONEncode Int, Real, Char, Bool, String, UNIT, PAIR, EITHER, FIELD, CONS, OBJECT, [], (,), (,,), {}, {!}, Maybe, JSONNode
/**
* Generic decoding function. This function should not be used
* directly, but always through the fromJSON function. It must be derived
* for each type you want to parse from JSON format.
*/
generic JSONDecode t :: [JSONNode] -> (!Maybe t,![JSONNode])
derive JSONDecode Int, Real, Char, Bool, String, UNIT, PAIR, EITHER, FIELD, CONS, OBJECT, [], (,), {}, {!}, Maybe, JSONNode
derive JSONDecode Int, Real, Char, Bool, String, UNIT, PAIR, EITHER, FIELD, CONS, OBJECT, [], (,), (,,), {}, {!}, Maybe, JSONNode
......@@ -335,6 +335,7 @@ JSONEncode{|CONS of d|} fx (CONS x)
JSONEncode{|FIELD of d|} fx (FIELD x) = fx x
JSONEncode{|[]|} fx x = [JSONArray (flatten [fx e \\ e <- x])]
JSONEncode{|(,)|} fx fy (x,y) = [JSONArray (fx x ++ fy y)]
JSONEncode{|(,,)|} fx fy fz (x,y,z) = [JSONArray (fx x ++ fy y ++ fz z)]
JSONEncode{|{}|} fx x = [JSONArray (flatten [fx e \\ e <-: x])]
JSONEncode{|{!}|} fx x = [JSONArray (flatten [fx e \\ e <-: x])]
JSONEncode{|Maybe|} fx (Just x) = fx x
......@@ -440,6 +441,18 @@ JSONDecode{|(,)|} fx fy l =:[JSONArray [xo,yo]:xs]
_ = (Nothing, l)
JSONDecode{|(,)|} fx fy l = (Nothing, l)
JSONDecode{|(,,)|} fx fy fz l =:[JSONArray [xo,yo,zo]:xs]
= case fx [xo] of
(Just x,_) = case fy [yo] of
(Just y,_) = case fz [zo] of
(Just z,_) = (Just (x,y,z), xs)
_ = (Nothing, l)
_ = (Nothing, l)
_ = (Nothing, l)
JSONDecode{|(,,)|} fx fy fz l = (Nothing, l)
JSONDecode{|{}|} fx l =:[JSONArray items:xs]
= case decodeItems fx items of
(Just x) = (Just {e \\ e <- x}, xs)
......
implementation module TaskService
import Http, TSt
import HtmlUtil, Text
import JSON
import StdList
import StdMisc // abort
......@@ -16,6 +17,8 @@ derive JSONDecode ManagerProperties, TaskPriority, User, UserDetails, Password
JSONEncode{|Timestamp|} (Timestamp x) = JSONEncode{|*|} x
JSONDecode{|Timestamp|} [JSONInt x:c] = (Just (Timestamp x),c)
import StdDebug
taskService :: !String !Bool ![String] !HTTPRequest *TSt -> (!HTTPResponse, !*TSt)
taskService url html path req tst
# (mbSessionErr,tst) = initSession sessionParam tst
......@@ -74,10 +77,14 @@ taskService url html path req tst
= (notFoundResponse req, tst)
Just proc
# task = taskItem proc
//Updates are posted as a list of triplets
# updates = case (fromJSON (fromString updatesParam)) of
Just updates = trace_n ("woot" +++ printToString updates ) updates
Nothing = trace_n "bummer" []
//The menusChanged parameter is a global flag that is set when any task in the tree has
//changed the menu and thus the menu needs to be replaced
# (tree,tst=:{TSt|menusChanged})
= calculateTaskTree taskId [] tst //TODO Add update events as parameter
= calculateTaskTree taskId updates tst
= case tree of
(TTMainTask ti properties menus _ content)
# tui = buildTaskPanel content menus menusChanged session.Session.user
......@@ -157,7 +164,8 @@ where
listParams = [("_session",sessionParam,True),("_user",userParam,False)]
detailsParams = [("_session",sessionParam,True)]
tuiParams = [("_session",sessionParam,True)]
tuiParams = [("_session",sessionParam,True),("updates",updatesParam,False)]
updatesParam = paramValue "updates" req
propParams = [("_session",sessionParam,True),("update",updateParam,False)]
updateParam = paramValue "update" req
......
......@@ -14,7 +14,7 @@ from TaskTree import :: TaskParallelType{..}
handleWorkTabRequest :: !HTTPRequest !*TSt -> (!HTTPResponse, !*TSt)
handleWorkTabRequest req tst=:{staticInfo,menusChanged}
# tst = {TSt | tst & request = req}
# (tree, tst) = calculateTaskTree taskId [] tst // Calculate the task tree TODO : add updates
# (tree, tst) = calculateTaskTree taskId updates tst
= case tree of
(TTMainTask ti properties menus _ task)
# subject = [properties.managerProperties.ManagerProperties.subject]
......@@ -50,7 +50,13 @@ where
finished tst
= let content = {TaskContent| success = True, properties = Nothing, subject = [], content = TaskDone, debug = Nothing} in
({http_emptyResponse & rsp_data = toString (toJSON content)}, tst)
updates = case http_getValue "_targettask" req.arg_post "" of
"" = []
target = [(target,name,value) \\ (name,value) <- req.arg_post | name.[0] <> '_']
:: TaskContent =
{ success :: Bool
, properties :: Maybe TaskProperties
......
......@@ -26,7 +26,7 @@ import GenPrint, GenParse, GenVisualize, GenUpdate
, tree :: !TaskTree // accumulator for constructing a task tree
, newTask :: !Bool // does the task run for the first time
, updates :: ![TaskUpdate] // The update events for interactive tasks
, events :: ![TaskEvent] // The update events for interactive tasks
// (task id, name, value)
, properties :: !TaskProperties // Properties of the current evaluated process
......@@ -142,7 +142,7 @@ garbageCollectTaskInstance :: !ProcessId !*TSt -> (!Bool,!*TSt)
*
* @return The modified task state
*/
evaluateTaskInstance :: !Process ![TaskUpdate] !(Maybe ChangeInjection) !Bool !Bool !*TSt-> (!TaskResult Dynamic, !TaskTree, !*TSt)
evaluateTaskInstance :: !Process ![TaskEvent] !(Maybe ChangeInjection) !Bool !Bool !*TSt-> (!TaskResult Dynamic, !TaskTree, !*TSt)
/**
* Applies a change to a running task process task state.
*
......@@ -163,7 +163,7 @@ applyChangeToTaskTree :: !ProcessId !ChangeInjection !*TSt -> *TSt
* @return Just an HtmlTree when the process is found, Nothing on failure
* @return The modified task state
*/
calculateTaskTree :: !TaskId ![TaskUpdate] !*TSt -> (!TaskTree, !*TSt)
calculateTaskTree :: !TaskId ![TaskEvent] !*TSt -> (!TaskTree, !*TSt)
/**
* Calculates all task trees
*
......@@ -173,7 +173,7 @@ calculateTaskTree :: !TaskId ![TaskUpdate] !*TSt -> (!TaskTree, !*TSt)
* @return The list of task trees (task forest)
* @return The modified task state
*/
calculateTaskForest :: ![TaskUpdate] !*TSt -> (![TaskTree], !*TSt)
calculateTaskForest :: ![TaskEvent] !*TSt -> (![TaskTree], !*TSt)
/**
* Lists which workflows are available
*
......@@ -384,10 +384,35 @@ setStatus :: ![HtmlTag] !*TSt -> *TSt //Only for monitor tasks
setGroupActions :: ![(Action, (Either Bool (*TSt -> *(!Bool,!*TSt))))] !*TSt -> *TSt //Only for group tasks
setFocusCommand :: !String !*TSt -> *TSt //Only for group tasks
getUserUpdates :: !*TSt -> ([(String,String)],!*TSt)
userUpdates2Paths :: ![(String,String)] -> [DataPath]
getChildrenUpdatesFor :: !TaskNr !*TSt -> ([(String,String)],!*TSt)
anyUpdates :: !*TSt -> (Bool,!*TSt)
//EVENTS
/**
* Get the events (name/value pairs) for the current task
*
* @param The task state
*
* @return The modified task state
*/
getEvents :: !*TSt -> ([(!String,!String)],!*TSt)
/**
* Get the events for a specific tasks
*
* @param The task id to get events for
* @param Include events of subtasks?
* @param The task state
*
* @return The modified task state
*/
getEventsFor :: !TaskId !Bool !*TSt -> ([(!String,!String)],!*TSt)
/**
* Test if there are events for any task during this run.
*
* @param The task state
*
* @return The test results
* @return The modified task state
*/
anyEvents :: !*TSt -> (!Bool,!*TSt)
/**
* Writes a 'task scoped' value to the store
......@@ -406,11 +431,7 @@ getTaskStoreFor :: !TaskNr !String !*TSt -> (Maybe a, !*TSt) | iTask a
*/
loadProcessResult :: !TaskNr !*TSt -> (!Maybe (TaskResult Dynamic), !*TSt)
storeProcessResult :: !TaskNr !(TaskResult Dynamic) !*TSt -> *TSt
/**
* Removes all events for the current task. This is automatically called by applyTask
* after task evaluation to prevent updates from being applied twice.
*/
clearUserUpdates :: !*TSt -> *TSt
/**
* Resets a sequence
*/
......@@ -456,3 +477,12 @@ taskNrFromString :: !String -> TaskNr
* @return The formatted task number
*/
taskNrToString :: !TaskNr -> String
/**
* Convert the names in events to data paths
*
* @param The events (name/value list)
*
* @return The converted data paths
*/
events2Paths :: ![(!String,!String)] -> [DataPath]
\ No newline at end of file
......@@ -33,7 +33,7 @@ mkTSt appName config request workflows store world
, taskInfo = initTaskInfo
, tree = TTMainTask initTaskInfo initTaskProperties Nothing Nothing (TTFinishedTask initTaskInfo [])
, newTask = True
, updates = []
, events = []
, properties = initTaskProperties
, menus = Nothing
, menusChanged = False
......@@ -217,8 +217,8 @@ loadThread processId tst=:{TSt|iworld = iworld =:{IWorld|store,world}}
//END NEW THREAD FUNCTIONS
//Computes a workflow (sub) process
evaluateTaskInstance :: !Process ![TaskUpdate] !(Maybe ChangeInjection) !Bool !Bool !*TSt-> (!TaskResult Dynamic, !TaskTree, !*TSt)
evaluateTaskInstance process=:{Process | taskId, properties, menus, changeCount, inParallelType} updates newChange isTop firstRun tst=:{TSt|currentChange,pendingChanges,tree=parentTree,updates=parentUpdates,properties=parentProperties,menus=parentMenus}
evaluateTaskInstance :: !Process ![TaskEvent] !(Maybe ChangeInjection) !Bool !Bool !*TSt-> (!TaskResult Dynamic, !TaskTree, !*TSt)
evaluateTaskInstance process=:{Process | taskId, properties, menus, changeCount, inParallelType} events newChange isTop firstRun tst=:{TSt|currentChange,pendingChanges,tree=parentTree,events=parentEvents,properties=parentProperties,menus=parentMenus}
// Update access timestamps in properties
# (now,tst) = accWorldTSt time tst
# properties = {properties & systemProperties = {properties.systemProperties
......@@ -227,7 +227,7 @@ evaluateTaskInstance process=:{Process | taskId, properties, menus, changeCount,
Nothing = Just now
Just t = Just t }}
// Reset the task state
# tst = resetTSt taskId updates properties inParallelType tst
# tst = resetTSt taskId events properties inParallelType tst
// Queue all stored persistent changes (only when run as top node)
# tst = if isTop (loadPersistentChanges taskId tst) tst
// When a change is injected set it as active change
......@@ -250,7 +250,7 @@ evaluateTaskInstance process=:{Process | taskId, properties, menus, changeCount,
# (tree,tst) = normalizeInteractiveTasks tree tst
// Store the adapted persistent changes
# tst = if isTop (storePersistentChanges taskId tst) tst
# tst = restoreTSt parentTree parentUpdates parentProperties parentMenus tst
# tst = restoreTSt parentTree parentEvents parentProperties parentMenus tst
= case result of
TaskBusy
//Update process table (changeCount & properties)
......@@ -271,7 +271,7 @@ evaluateTaskInstance process=:{Process | taskId, properties, menus, changeCount,
Nothing
= (result,tree,tst)
Just parentProcess
# (_,_,tst) = evaluateTaskInstance parentProcess updates Nothing True False tst
# (_,_,tst) = evaluateTaskInstance parentProcess events Nothing True False tst
= (result,tree,tst)
| otherwise
= (result,tree,tst)
......@@ -288,18 +288,18 @@ evaluateTaskInstance process=:{Process | taskId, properties, menus, changeCount,
# (_,tst) = updateProcess taskId (\p -> {Process|p & properties = properties, menus = menus, changeCount = changeCount }) tst
= (TaskException e, tree, tst)
where
resetTSt :: !TaskId ![TaskUpdate] !TaskProperties !(Maybe TaskParallelType) !*TSt -> *TSt
resetTSt taskId updates properties inptype tst
resetTSt :: !TaskId ![TaskEvent] !TaskProperties !(Maybe TaskParallelType) !*TSt -> *TSt
resetTSt taskId events properties inptype tst
# taskNr = taskNrFromString taskId
# info = { initTaskInfo
& taskId = taskId
, taskLabel = properties.managerProperties.subject
}
# tree = TTMainTask info properties menus inptype (TTFinishedTask info [Text "Dummy"])
= {TSt| tst & taskNr = taskNr, tree = tree, updates = updates, staticInfo = {tst.staticInfo & currentProcessId = taskId}}
= {TSt| tst & taskNr = taskNr, tree = tree, events = events, staticInfo = {tst.staticInfo & currentProcessId = taskId}}
restoreTSt :: !TaskTree ![TaskUpdate] !TaskProperties !(Maybe [Menu]) !*TSt -> *TSt
restoreTSt tree updates properties menus tst = {TSt|tst & tree = tree, updates = updates, properties = properties, menus = menus}
restoreTSt :: !TaskTree ![TaskEvent] !TaskProperties !(Maybe [Menu]) !*TSt -> *TSt
restoreTSt tree events properties menus tst = {TSt|tst & tree = tree, events = events, properties = properties, menus = menus}
/*
* Load all stored persistent changes that are applicable to the current (sub) process.
* In case of evaluating a subprocess, this also includes the changes that have been injected
......@@ -503,8 +503,8 @@ applyChangeToTaskTree pid (lifetime,change) tst=:{taskNr,taskInfo,tree,staticInf
import StdDebug
calculateTaskTree :: !TaskId ![TaskUpdate] !*TSt -> (!TaskTree, !*TSt)
calculateTaskTree taskId updates tst
calculateTaskTree :: !TaskId ![TaskEvent] !*TSt -> (!TaskTree, !*TSt)
calculateTaskTree taskId events tst
# (mbProcess,tst) = getProcess taskId tst
= case mbProcess of
Nothing
......@@ -518,7 +518,7 @@ calculateTaskTree taskId updates tst
= case properties.systemProperties.SystemProperties.status of
Active
//Evaluate the process
# (result,tree,tst) = evaluateTaskInstance process updates Nothing True False tst
# (result,tree,tst) = evaluateTaskInstance process events Nothing True False tst
= (tree,tst)
_
//retrieve process result from store and show it??
......@@ -537,14 +537,14 @@ where
renderResult :: Dynamic -> [HtmlTag]
renderResult (Container value :: Container a a) = visualizeAsHtmlDisplay value
calculateTaskForest :: ![TaskUpdate] !*TSt -> (![TaskTree], !*TSt)
calculateTaskForest updates tst
calculateTaskForest :: ![TaskEvent] !*TSt -> (![TaskTree], !*TSt)
calculateTaskForest events tst
# (processes, tst) = getProcesses [Active] tst
= calculateTrees [taskId \\ {Process|taskId,properties} <- processes | isNothing properties.systemProperties.parent] tst
where
calculateTrees [] tst = ([],tst)
calculateTrees [p:ps] tst
# (tree,tst) = calculateTaskTree p updates tst
# (tree,tst) = calculateTaskTree p events tst
# (trees,tst) = calculateTrees ps tst
= ([tree:trees],tst)
......@@ -737,7 +737,7 @@ applyTask (Task initProperties groupedProperties mbInitTaskNr taskfun) tst=:{tas
// Execute task function
# (result, tst) = taskfun tst
// Remove user updates (needed for looping. a new task may get the same tasknr again, but should not get the events)
# tst=:{tree=node,iworld=iworld=:{IWorld|store}} = clearUserUpdates tst
# tst=:{tree=node,iworld=iworld=:{IWorld|store}} = {TSt|tst & events = []}
// Update task state
= case result of
(TaskFinished a)
......@@ -876,38 +876,21 @@ getTaskStoreFor taskNr key tst=:{TSt|iworld=iworld=:{IWorld|store,world}}
where
storekey = "iTask_" +++ (taskNrToString taskNr) +++ "-" +++ key
getUserUpdates :: !*TSt -> ([(String,String)],!*TSt)
getUserUpdates tst=:{taskNr,request} = (updates request, tst)
where
updates request
| http_getValue "_targettask" request.arg_post "" == taskNrToString taskNr
= [u \\ u =:(k,v) <- request.arg_post | k.[0] <> '_']
| otherwise
= []
userUpdates2Paths :: ![(String,String)] -> [DataPath]
//userUpdates2Paths updates = map s2dp (fst (unzip updates))
userUpdates2Paths updates = map (s2dp o fst) updates
getChildrenUpdatesFor :: !TaskNr !*TSt -> ([(String,String)],!*TSt)
getChildrenUpdatesFor taskNr tst=:{request} = (updates request, tst);
getEvents :: !*TSt -> ([(!String,!String)],!*TSt)
getEvents tst=:{taskNr,events}
= ([(name,value) \\ (task,name,value) <- events | task == taskId], tst)
where
updates request
| startsWith (taskNrToString taskNr) (http_getValue "_targettask" request.arg_post "")
= [u \\ u =:(k,v) <- request.arg_post]
| otherwise
= []
anyUpdates :: !*TSt -> (Bool,!*TSt)
anyUpdates tst=:{request} = (http_getValue "_targettask" request.arg_post "" <> "",tst)
clearUserUpdates :: !*TSt -> *TSt
clearUserUpdates tst=:{taskNr, request}
| http_getValue "_targettask" request.arg_post "" == taskNrToString taskNr
= {tst & request = {request & arg_post = [u \\ u =:(k,v) <- request.arg_post | k.[0] == '_']}}
| otherwise
= tst
taskId = taskNrToString taskNr
getEventsFor :: !TaskId !Bool !*TSt -> ([(!String,!String)],!*TSt)
getEventsFor taskId includeSub tst=:{TSt|events}
= ([(name,value) \\ (task,name,value) <- events | if includeSub (startsWith taskId task) (taskId == task)], tst)
anyEvents :: !*TSt -> (!Bool,!*TSt)
anyEvents tst=:{TSt|events} = (not (isEmpty events),tst)
resetSequence :: !*TSt -> *TSt
resetSequence tst=:{taskNr,tree}
= case tree of
......@@ -953,4 +936,7 @@ where
stl :: [Char] -> [Char]
stl [] = []
stl xs = tl xs
\ No newline at end of file
stl xs = tl xs
events2Paths :: ![(!String,!String)] -> [DataPath]
events2Paths updates = map (s2dp o fst) updates
\ No newline at end of file
......@@ -141,7 +141,7 @@ initGroupedProperties :: GroupedProperties
:: Container a c = Container a & iTask c // container for context restrictions
:: TaskUpdate :== (!TaskId,!String,!String) // taskid, name, value
:: TaskEvent :== (!TaskId,!String,!String) // taskid, name, value
:: *IWorld = { application :: !String // The name of the application
, store :: !Store // The generic data store
......
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