TSt.icl 22.9 KB
Newer Older
1 2 3
implementation module TSt

import StdEnv, StdMaybe
4
import Http, Util
5
import ProcessDB, DynamicDB, SessionDB, DocumentDB, UserDB, TaskTree
6 7
import CommonDomain

8
import GenPrint, GenParse, GenEq
9
import GenVisualize, GenUpdate, Store, Config
10

11 12
import dynamic_string

13
from JSON import JSONDecode, fromJSON
14

15 16
:: TaskState = TSNew | TSActive | TSDone

17 18 19 20 21 22 23 24
:: RPCMessage =
			{ success		:: Bool
			, error			:: Bool
			, finished		:: Bool
			, result		:: String
			, status		:: String
			, errormsg		:: String
			}
25

26 27 28
derive gPrint		TaskState
derive gParse		TaskState
derive gEq			TaskState
29
derive bimap 		Maybe, (,)
30 31
derive JSONDecode RPCMessage

32 33
mkTSt :: String Config HTTPRequest Session ![Workflow] !*Store !*Store !*Store !*World -> *TSt
mkTSt appName config request session workflows systemStore dataStore fileStore world
34 35
	=	{ taskNr		= []
		, taskInfo		= initTaskInfo
36
		, firstRun		= False
Bas Lijnse's avatar
Bas Lijnse committed
37
		, curValue		= Nothing
38
		, userId		= -1
39
		, delegatorId	= -1
40
		, tree			= TTMainTask initTaskInfo initTaskProperties []
41
		, activated 	= True
42
		, mainTask		= ""
43
		, options 		= initialOptions
44
		, staticInfo	= initStaticInfo appName session workflows
45
		, exception		= Nothing
46
		, doChange		= False
47
		, changes		= []
48
		, config		= config
49
		, request		= request
ecrombag's avatar
ecrombag committed
50 51
		, systemStore	= systemStore
		, dataStore		= dataStore
52
		, documentStore	= fileStore
53
		, world			= world
54 55
		}

56 57 58
initStaticInfo :: String Session ![Workflow] -> StaticInfo
initStaticInfo appName session workflows
	=	{ appName			= appName
59
		, currentProcessId	= ""
60 61
		, currentSession 	= session
		, staticWorkflows	= workflows
62 63
		}

64 65 66
initialOptions :: Options 
initialOptions
	=	{ trace			= False 
67 68
		}

69 70 71 72 73 74 75 76 77 78 79
initTaskInfo :: TaskInfo
initTaskInfo
	=	{ TaskInfo
		| taskId = ""
		, taskLabel = ""
		, active = True
		, traceValue = ""
		}

initTaskProperties :: TaskProperties
initTaskProperties
80 81
	= { systemProps =
		{TaskSystemProperties
82
		| processId = ""
83
		, manager = (-1,"")
84
		, issuedAt = Timestamp 0
85 86
		, firstEvent = Nothing
		, latestEvent = Nothing
87
		, latestExtEvent = Nothing
88
		}
89 90 91
	  , managerProps =
	    {TaskManagerProperties
	    | worker = (-1,"")
92
	    , subject = ""
93 94 95 96 97 98 99 100
	    , priority = NormalPriority
	    , deadline = Nothing
	    }
	  , workerProps =
	    {TaskWorkerProperties
	    | progress = TPActive
	    }
	 }
101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
	  
createTaskInstance :: !(Task a) !TaskManagerProperties !Bool !*TSt -> (!ProcessId, !*TSt) | iTask a
createTaskInstance task managerProps toplevel tst=:{taskNr,mainTask}
	# (managerId, tst)		= getCurrentUser tst
	# (manager,tst)			= getUser managerId tst
	# (currentTime, tst)	= accWorldTSt time tst
	# processId				= if toplevel "" (taskNrToString taskNr)
	# parent				= if toplevel "" mainTask
	# properties =
		{TaskProperties
		| systemProps =
			{TaskSystemProperties
			| processId	= ""
			, manager		= (manager.User.userId, manager.User.displayName)
			, issuedAt	= currentTime
			, firstEvent	= Nothing
			, latestEvent	= Nothing
118
			, latestExtEvent = Nothing
119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
			}
		, managerProps = managerProps
		, workerProps =
			{TaskWorkerProperties
			| progress	= TPActive
			}
		}
	# process =
		{ Process
		| processId		= processId
		, status		= Active
		, parent		= parent
		, properties	= properties
		, changes		= []
		, changeNr		= 0
		}
	//Create an entry in the process table
	# (processId, tst)	= createProcess process tst
	//Store the task as dynamic
	# tst				= storeTaskFunctionStatic (taskNrFromString processId) task tst
	//Store the runnable theread
	# tst				= storeTaskThread (taskNrFromString processId) (createTaskThread task) tst	
	//Evaluate the process once to kickstart automated steps that can be set in motion immediately
	# (_,tst)			= calculateTaskTree processId tst
	= (processId,tst)

calculateTaskTree :: !ProcessId !*TSt -> (!TaskTree, !*TSt)
calculateTaskTree processId tst
	# (mbProcess,tst) = getProcess processId tst
	| isNothing mbProcess
149
		= (TTFinishedTask {TaskInfo|taskId = toString processId, taskLabel = "Deleted Process", active = True, traceValue="Deleted"}, tst)
150 151 152 153 154 155
	# process=:{status,parent,properties} = fromJust mbProcess
	= case status of
		Active
			# (tree,tst=:{activated}) = buildProcessTree process Nothing tst
			//When finished, also evaluate the parent tree (and it's parent when it is also finished etc...)
			| activated && parent <> ""
156
				# (_,tst)	= calculateTaskTree parent {tst & activated = True} 
157 158 159 160
				= (tree, tst)
			| otherwise
				= (tree, tst)
		_
161
			= (TTFinishedTask {TaskInfo|taskId = toString processId, taskLabel = properties.managerProps.subject, active = True, traceValue = "Finished"}, tst)
162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177

calculateTaskForest :: !*TSt -> (![TaskTree], !*TSt)
calculateTaskForest tst 
	# (processes, tst) = getProcesses [Active] tst
	= calculateTrees [processId \\ {Process|processId} <- processes | isTopLevel processId] tst
where
	isTopLevel p	= length (taskNrFromString p) == 1
	
	calculateTrees []     tst = ([],tst)
	calculateTrees [p:ps] tst
		# (tree,tst)	= calculateTaskTree p tst
		# (trees,tst)	= calculateTrees ps tst
		= ([tree:trees],tst)

//If parent has to be evaluated, the Id is returned and accumulated into the list of proccesses still to be evaluated in buildtree.
buildProcessTree :: Process !(Maybe (Dynamic, ChangeLifeTime)) !*TSt -> (!TaskTree, !*TSt)
178
buildProcessTree p =: {Process | processId, parent, properties = {TaskProperties|systemProps,managerProps}, changes, changeNr} mbChange tst =:{taskNr,staticInfo}
179

180
	# tst									= {TSt|tst & taskNr = [changeNr:taskNrFromString processId], activated = True, userId = (fst managerProps.worker), delegatorId = (fst systemProps.manager)
181
												, staticInfo = {StaticInfo|staticInfo & currentProcessId = processId}, tree = initProcessNode p, mainTask = processId}
182
	# tst									= loadChanges mbChange changes tst
183
	# (result, tst)							= executeTaskThread tst
184 185
	# (TTMainTask ti mti tasks, tst=:{activated})	= getTaskTree tst
	| activated
186 187
		# tst 			= storeProcessResult (taskNrFromString processId) result tst
		# (_,tst)		= updateProcess processId (\p -> {Process|p & status = Finished}) tst
188
		= (TTFinishedTask ti, tst)
189
	| otherwise
190 191 192 193
		# tst			= storeChanges processId tst
		= (TTMainTask ti mti tasks, tst)	
where	
	initProcessNode {Process|processId, properties}
194
		= TTMainTask {TaskInfo|taskId = toString processId, taskLabel = properties.managerProps.subject, active = True, traceValue = "Process"} properties []
195
	
196 197
	loadChanges mbNew changes tst = loadChanges` mbNew changes [] tst

198 199 200 201
	loadChanges` Nothing [] accu tst=:{TSt|changes}
		= {TSt|tst& changes = reverse accu, doChange = False}
	loadChanges` (Just (change,lifetime)) [] accu tst=:{TSt|changes}
		= {TSt|tst & changes = [Just (lifetime, 0,change):changes], doChange = True}
202
	loadChanges` mbNew [(l,c):cs] accu tst
203
		# (dyn,tst) = getDynamic c tst
204
		= case dyn of
205 206
			Just dyn	= loadChanges` mbNew cs [Just (CLPersistent l,c,dyn):accu] tst
			Nothing		= loadChanges` mbNew cs accu tst
207
	
208
	storeChanges pid tst=:{TSt|changes} = storeChanges` changes [] pid tst
209
	storeChanges` [] accu pid tst
210
		# (_,tst)	= updateProcess pid (\p -> {Process|p & changes = reverse accu}) tst
211
		= tst
212
	storeChanges` [Just(CLPersistent l,c,d):cs] accu pid tst
213
		| c == 0
214
			# (c,tst)	= createDynamic d tst
215 216
			= storeChanges` cs [(l,c):accu] pid tst
		| otherwise
217
			# (_,tst)	= updateDynamic d c tst
218
			= storeChanges` cs [(l,c):accu] pid tst
219
	storeChanges` [c:cs] accu pid tst
220
		= storeChanges` cs accu pid tst
221

222
	executeTaskThread tst=:{taskNr}
223 224 225 226 227
		# (thread, tst)		= loadTaskThread (taskNrFromString processId) tst		  
		# (result, tst) 	= thread tst
		= (result,tst)


228 229 230 231 232 233
createTaskThread :: !(Task a) -> (*TSt -> *(!Dynamic,!*TSt)) | iTask a
createTaskThread task = createTaskThread` task
where
	createTaskThread` :: !(Task a) !*TSt -> *(!Dynamic, !*TSt) | iTask a
	createTaskThread` task tst
		# (a, tst)	= applyTask task tst
234
		# dyn		= (dynamic a)
235 236 237 238
		= (dyn,tst)



239
applyChangeToTaskTree :: !ProcessId !Dynamic !ChangeLifeTime !*TSt -> *TSt
240
applyChangeToTaskTree pid change lifetime tst=:{taskNr,taskInfo,firstRun,userId,delegatorId,tree,activated,mainTask,options,staticInfo,exception,doChange,changes}
241
	# (mbProcess,tst) = getProcess pid tst
242
	= case mbProcess of
243
		(Just proc) 
244
			# tst = snd (buildProcessTree proc (Just (change,lifetime)) tst)
245
			= {tst & taskNr = taskNr, taskInfo = taskInfo, firstRun = firstRun, userId = userId, delegatorId = delegatorId
246
			  , tree = tree, activated = activated, mainTask = mainTask, options = options
247
			  , staticInfo = staticInfo, exception = exception, doChange = doChange, changes = changes}
248
		Nothing		
249 250
			= tst

251 252 253 254 255
getCurrentSession :: !*TSt 	-> (!Session, !*TSt)
getCurrentSession tst =:{staticInfo} = (staticInfo.currentSession, tst)

getCurrentUser :: !*TSt -> (!UserId, !*TSt)
getCurrentUser tst =: {staticInfo}
Bas Lijnse's avatar
Bas Lijnse committed
256
	= (staticInfo.currentSession.Session.user.User.userId, {tst & staticInfo = staticInfo})
257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276

getCurrentProcess :: !*TSt -> (!ProcessId, !*TSt)
getCurrentProcess tst =: {staticInfo}
	= (staticInfo.currentProcessId, {tst & staticInfo = staticInfo})

getTaskTree :: !*TSt	-> (!TaskTree, !*TSt)
getTaskTree tst =: {tree}
	= (tree, {tst & tree = tree})

getWorkflows :: !*TSt -> (![Workflow],!*TSt)
getWorkflows tst=:{staticInfo = staticInfo =:{staticWorkflows}}
	= (staticWorkflows, {tst & staticInfo = {staticInfo & staticWorkflows = staticWorkflows}})

getWorkflowByName :: !String !*TSt -> (!Maybe Workflow, !*TSt)
getWorkflowByName name tst
	# (workflows, tst)	= getWorkflows tst
	= case filter (\wf -> wf.Workflow.name == name) workflows of
		[workflow]	= (Just workflow, tst)
		_			= (Nothing,tst)

277 278 279
appWorldTSt	:: !.(*World -> *World) !*TSt -> *TSt
appWorldTSt f tst=:{TSt|world}
	= {TSt|tst & world = f world}
280

281 282 283 284 285
accWorldTSt	:: !.(*World -> *(.a,*World))!*TSt -> (.a,!*TSt)
accWorldTSt f tst=:{TSt|world}
	# (a,world) = f world
	= (a, {TSt|tst & world = world})
		
286
mkInteractiveTask	:: !String !(*TSt -> *(!a,!*TSt)) -> Task a 
287
mkInteractiveTask taskname taskfun = Task {TaskDescription| title = taskname, description = Note ""} Nothing mkInteractiveTask`	
Bas Lijnse's avatar
Bas Lijnse committed
288
where
289
	mkInteractiveTask` tst=:{TSt|taskNr,taskInfo}
290
		= taskfun {tst & tree = TTInteractiveTask taskInfo (abort "No interface definition given"), activated = True}
Bas Lijnse's avatar
Bas Lijnse committed
291 292

mkInstantTask :: !String !(*TSt -> *(!a,!*TSt)) -> Task a
293
mkInstantTask taskname taskfun = Task {TaskDescription| title = taskname, description = Note ""} Nothing mkInstantTask`
Bas Lijnse's avatar
Bas Lijnse committed
294 295
where
	mkInstantTask` tst=:{TSt|taskNr,taskInfo}
296
		= taskfun {tst & tree = TTFinishedTask taskInfo, activated = True} //We use a FinishedTask node because the task is finished after one evaluation
Bas Lijnse's avatar
Bas Lijnse committed
297 298

mkMonitorTask :: !String !(*TSt -> *(!a,!*TSt)) -> Task a
299
mkMonitorTask taskname taskfun = Task {TaskDescription| title = taskname, description = Note ""} Nothing mkMonitorTask`
Bas Lijnse's avatar
Bas Lijnse committed
300 301
where
	mkMonitorTask` tst=:{TSt|taskNr,taskInfo}
302
		= taskfun {tst & tree = TTMonitorTask taskInfo [], activated = True}
303

304
mkRpcTask :: !String !RPCExecute !(String -> a) -> Task a | gUpdate{|*|} a
305
mkRpcTask taskname rpce parsefun = Task {TaskDescription| title = taskname, description = Note ""} Nothing mkRpcTask`
306
where
307
	mkRpcTask` tst=:{TSt | taskNr, taskInfo}
308
		# rpce				= {RPCExecute | rpce & taskId = taskNrToString taskNr}
309
		# (updates, tst) 	= getRpcUpdates tst
310
		# (rpce, tst) 		= checkRpcStatus rpce tst
311
		| length updates == 0 
312
			= applyRpcDefault {tst & activated = False, tree = TTRpcTask taskInfo rpce }					
313
		| otherwise 
314
			= applyRpcUpdates updates tst rpce parsefun
315
	
316 317
	checkRpcStatus :: RPCExecute !*TSt -> (!RPCExecute, !*TSt)
	checkRpcStatus rpce tst 
318 319 320 321
		# (mbStatus, tst) = getTaskStore "status" tst 
		= case mbStatus of
		Nothing 
			# tst = setTaskStore "status" "Pending" tst
322
			= ({RPCExecute | rpce & status = "Pending"},tst)
323
		Just s
324
			= ({RPCExecute | rpce & status = s},tst)
325
	
326 327 328 329 330 331 332 333 334 335
	getRpcUpdates :: !*TSt -> ([(String,String)],!*TSt)
	getRpcUpdates tst=:{taskNr,request} = (updates request, tst)
	where
		updates request
			| http_getValue "_rpctaskid" request.arg_post "" == taskNrToString taskNr
				= [u \\ u =: (k,v) <- request.arg_post]
			| otherwise
				= []

/* Error handling needs to be implemented! */	
336 337 338 339
applyRpcUpdates :: [(String,String)] !*TSt !RPCExecute !(String -> a) -> *(!a,!*TSt) | gUpdate{|*|} a	
applyRpcUpdates [] tst rpce parsefun = applyRpcDefault tst
applyRpcUpdates [(n,v):xs] tst rpce parsefun
| n == "_rpcresult" 
ecrombag's avatar
ecrombag committed
340
# (mbMsg) = fromJSON v
341
= case mbMsg of
342
	Just msg = applyRpcMessage msg tst rpce parsefun
343
	Nothing  = applyRpcUpdates xs tst rpce parsefun //Ignore the message and go on..
344
| otherwise  = applyRpcUpdates xs tst rpce parsefun
345 346
where
	applyRpcMessage msg tst rpci parsfun
347
	# tst = setStatus msg.RPCMessage.status tst
348 349
	= case msg.RPCMessage.success of
		True
350 351
			# tst = checkFinished msg.RPCMessage.finished tst
			= (parsefun msg.RPCMessage.result, tst)
352
		False
353 354
			# tst = {TSt | tst & activated = True}
			= applyRpcDefault tst
355 356 357
	
	checkFinished True 	tst = {TSt | tst & activated = True}
	checkFinished False tst = {TSt | tst & activated = False}
358

359 360 361 362
	setStatus status tst
	| status <> "" =  (setTaskStore "status" status tst)
	| otherwise = tst

363 364 365
applyRpcDefault :: !*TSt -> *(!a,!*TSt) | gUpdate{|*|} a
applyRpcDefault tst=:{TSt|world}
	# (def,wrld) = defaultValue world
366
	= (def,{TSt | tst & world=wrld})
367

368
	
369
mkSequenceTask :: !String !(*TSt -> *(!a,!*TSt)) -> Task a
370
mkSequenceTask taskname taskfun = Task {TaskDescription| title = taskname, description = Note ""} Nothing mkSequenceTask`
371
where
372 373
	mkSequenceTask` tst=:{TSt|taskNr,taskInfo}
		= taskfun {tst & tree = TTSequenceTask taskInfo [], taskNr = [0:taskNr]}
374
			
375
mkParallelTask :: !String !(*TSt -> *(!a,!*TSt)) -> Task a
376
mkParallelTask taskname taskfun = Task {TaskDescription| title = taskname, description = Note ""} Nothing mkParallelTask`
377
where
378 379
	mkParallelTask` tst=:{TSt|taskNr,taskInfo}
		# tst = {tst & tree = TTParallelTask taskInfo [], taskNr = [0:taskNr]}												
380 381
		= taskfun tst
			
382
mkMainTask :: !String !(*TSt -> *(!a,!*TSt)) -> Task a
383
mkMainTask taskname taskfun = Task {TaskDescription| title = taskname, description = Note ""} Nothing mkMainTask`
384
where
385
	mkMainTask` tst=:{taskNr,taskInfo}
386
		= taskfun {tst & tree = TTMainTask taskInfo (abort "Executed undefined maintask") []}
ecrombag's avatar
ecrombag committed
387

388
applyTask :: !(Task a) !*TSt -> (!a,!*TSt) | iTask a
389
applyTask (Task desc mbCxt taskfun) tst=:{taskNr,tree=tree,options,activated,dataStore,world}
390
	# taskId				= iTaskId taskNr ""
ecrombag's avatar
ecrombag committed
391
	# (mbtv,dstore,world)	= loadValue taskId dataStore world
392 393 394
	# (state,curval)		= case mbtv of
								(Just (state, value))	= (state, Just value)
								_						= (TSNew, Nothing)
395
	# taskInfo =	{ taskId		= taskNrToString taskNr
396
					, taskLabel		= desc.TaskDescription.title
397
					, active		= activated
398
					, traceValue	= ""
399
					}
ecrombag's avatar
ecrombag committed
400
	# tst = {TSt|tst & dataStore = dstore, world = world}
401 402 403 404
	| state === TSDone
		# traceValue = if (isJust curval) (printToString (fromJust curval)) ""
		# tst = addTaskNode (TTFinishedTask {taskInfo & traceValue = traceValue}) tst
		= (fromJust curval, {tst & taskNr = incTaskNr taskNr, activated = True})
405
	| otherwise
406
		# tst	= {tst & taskInfo = taskInfo, firstRun = state === TSNew, curValue = case curval of Nothing = Nothing ; Just a = Just (dynamic a)}	
407 408
		// If the task is new, but has run in a different context, initialize the states of the task and its subtasks
		# tst	= initializeState state taskNr mbCxt tst
409
		// Execute task function
410 411
		# (a, tst)	= taskfun tst
		// Remove user updates (needed for looping. a new task may get the same tasknr again, but should not get the events)
ecrombag's avatar
ecrombag committed
412
		# tst=:{tree=node,activated,dataStore}	= clearUserUpdates tst
413
		// Update task state
414
		| activated
415
			//Garbage collect
ecrombag's avatar
ecrombag committed
416
			# tst=:{TSt|dataStore}	= deleteTaskStates taskNr {TSt|tst & dataStore = dataStore}
417
			// Store final value
ecrombag's avatar
ecrombag committed
418 419
			# dataStore				= storeValue taskId (TSDone, a) dataStore
			# tst					= addTaskNode (TTFinishedTask {taskInfo & traceValue = printToString a}) {tst & taskNr = incTaskNr taskNr, tree = tree, options = options, dataStore = dataStore}
420
			= (a, tst)
421
		| otherwise
422
			# node				= updateTaskNode (printToString a) node
ecrombag's avatar
ecrombag committed
423 424
			# dataStore			= storeValue taskId (TSActive, a) dataStore
			# tst				= addTaskNode node {tst & taskNr = incTaskNr taskNr, tree = tree, options = options, dataStore = dataStore}
425 426
			= (a, tst)
	
427 428
where
	//Increase the task nr
429 430
	incTaskNr [] = [0]
	incTaskNr [i:is] = [i+1:is]
431
	
432 433 434
	initializeState TSNew taskNr (Just oldTaskNr) tst	= copyTaskStates oldTaskNr taskNr tst
	initializeState _ _ _ tst							= tst
	
435
	//Add a new node to the current sequence or process
436
	addTaskNode node tst=:{tree} = case tree of
437 438 439 440
		(TTMainTask ti mti tasks)	= {tst & tree = TTMainTask ti mti [node:tasks]}
		(TTSequenceTask ti tasks)	= {tst & tree = TTSequenceTask ti [node:tasks]}
		(TTParallelTask ti tasks)	= {tst & tree = TTParallelTask ti [node:tasks]}
		_							= {tst & tree = tree}
441 442
	
	//update the finished, tasks and traceValue fields of a task tree node
443 444 445 446 447 448
	updateTaskNode tv (TTInteractiveTask ti defs)		= TTInteractiveTask	{ti & traceValue = tv} defs
	updateTaskNode tv (TTMonitorTask ti status)		= TTMonitorTask		{ti & traceValue = tv} status
	updateTaskNode tv (TTSequenceTask ti tasks) 		= TTSequenceTask	{ti & traceValue = tv} (reverse tasks)
	updateTaskNode tv (TTParallelTask ti tasks)		= TTParallelTask	{ti & traceValue = tv} (reverse tasks)
	updateTaskNode tv (TTMainTask ti mti tasks)		= TTMainTask		{ti & traceValue = tv} mti (reverse tasks)		
	updateTaskNode tv (TTRpcTask ti rpci)				= TTRpcTask			{ti & traceValue = tv} rpci
449
		
450 451
setTUIDef	:: !TUIDef !*TSt -> *TSt
setTUIDef def tst=:{tree}
Bas Lijnse's avatar
Bas Lijnse committed
452
	= case tree of
453
		(TTInteractiveTask info _)			= {tst & tree = TTInteractiveTask info (Left def)}
Bas Lijnse's avatar
Bas Lijnse committed
454 455
		_									= tst

456 457
setTUIUpdates :: ![TUIUpdate] !*TSt -> *TSt
setTUIUpdates upd tst=:{tree}
Bas Lijnse's avatar
Bas Lijnse committed
458
	= case tree of
459
		(TTInteractiveTask info _)			= {tst & tree = TTInteractiveTask info (Right upd)}
Bas Lijnse's avatar
Bas Lijnse committed
460 461
		_									= tst

Bas Lijnse's avatar
Bas Lijnse committed
462 463 464 465 466
setStatus :: ![HtmlTag] !*TSt -> *TSt
setStatus msg tst=:{tree}
	= case tree of
		(TTMonitorTask info _)				= {tst & tree = TTMonitorTask info msg}
		_									= tst
Bas Lijnse's avatar
Bas Lijnse committed
467 468 469 470 471

getTaskValue :: !*TSt -> (Maybe a, !*TSt) | TC a
getTaskValue tst=:{curValue = Just (a :: a^)} = (Just a, tst)
getTaskValue tst = (Nothing, tst)

472 473 474 475 476 477 478 479 480 481 482 483 484 485
loadTaskFunctionStatic :: !TaskNr !*TSt -> (!Maybe (Task a), !*TSt) | TC a
loadTaskFunctionStatic taskNr tst =: {TSt | dataStore, world}
# (mbDyn, dataStore, world) = loadValue (storekey taskNr) dataStore world
= case mbDyn of 
	(Just (t :: Task a^)) 	= ((Just t), {TSt | tst & dataStore = dataStore, world = world})
	Nothing				  	= (Nothing , {TSt | tst & dataStore = dataStore, world = world})
where
	storekey taskNr  	 = "iTask_"+++(taskNrToString taskNr)+++"-taskfun-static"

storeTaskFunctionStatic :: !TaskNr !(Task a) !*TSt -> *TSt | TC a
storeTaskFunctionStatic taskNr task tst = storeTaskFunction taskNr task "static" tst

storeTaskFunction :: !TaskNr !(Task a) String !*TSt -> *TSt | TC a
storeTaskFunction taskNr task key tst =: {TSt | dataStore}
486
# dataStore = storeValueAs SFPlain (storekey taskNr key) (dynamic task) dataStore
487 488 489 490
= {TSt | tst & dataStore = dataStore}
where
	storekey taskNr key = "iTask_"+++(taskNrToString taskNr)+++"-taskfun-"+++key 

491
storeTaskThread :: !TaskNr !(*TSt -> *(!Dynamic,!*TSt)) !*TSt -> *TSt
492
storeTaskThread taskNr thread tst =:{dataStore}
493
	# dataStore = storeValueAs SFDynamic key (dynamic thread :: *TSt -> *(!Dynamic,!*TSt)) dataStore
494 495 496 497
	= {TSt | tst & dataStore = dataStore}
where
	key = "iTask_" +++ (taskNrToString taskNr) +++ "-thread"

498
loadTaskThread :: !TaskNr !*TSt -> (*TSt -> *(!Dynamic,!*TSt), !*TSt)
499 500 501
loadTaskThread taskNr tst =:{dataStore,world}
	# (mbDyn, dataStore, world)	= loadValue key dataStore world
	= case mbDyn of
502
		(Just (f :: *TSt -> *(!Dynamic, !*TSt)))
503 504 505 506 507 508 509 510 511
			= (f, {TSt | tst & dataStore = dataStore, world = world})
		(Just _)
			= abort ("(loadTaskThread) Failed to match thread for " +++ taskNrToString taskNr)
		Nothing
			= abort ("(loadTaskThread) Failed to load thread for " +++ taskNrToString taskNr)	
where
	key = "iTask_" +++ (taskNrToString taskNr) +++ "-thread"


512 513 514 515 516
/**
* Store and load the result of a workflow instance
*/
loadProcessResult :: !TaskNr !*TSt -> (!Maybe a, !*TSt) | TC a
loadProcessResult taskNr tst =:{dataStore, world}
517
	# (mbDyn, dataStore, world) = loadValue key dataStore world
518 519 520 521
	= case mbDyn of
		( Just (result :: a^))	= (Just result, {TSt | tst & dataStore = dataStore, world = world})
		Nothing					= (Nothing, {TSt | tst & dataStore = dataStore, world = world})
where
522
	key = "iTask_"+++(taskNrToString taskNr)+++"-result"
523 524 525
	
storeProcessResult :: !TaskNr !Dynamic !*TSt -> *TSt
storeProcessResult taskNr result tst=:{dataStore}
526
	# dataStore	= storeValueAs SFDynamic key result dataStore
527 528
	= {TSt |tst & dataStore = dataStore}
where
529
	key = "iTask_"+++(taskNrToString taskNr)+++"-result"
530
	
531
setTaskStore :: !String !a !*TSt -> *TSt | iTask a
ecrombag's avatar
ecrombag committed
532 533 534
setTaskStore key value tst=:{taskNr,dataStore}
	# dataStore = storeValue storekey value dataStore
	= {TSt|tst & dataStore = dataStore}
535
where
ecrombag's avatar
ecrombag committed
536
	storekey = "iTask_" +++ (taskNrToString taskNr) +++ "-" +++ key
537 538

getTaskStore :: !String !*TSt -> (Maybe a, !*TSt) | iTask a
ecrombag's avatar
ecrombag committed
539 540 541
getTaskStore key tst=:{taskNr,dataStore,world}
	# (mbValue,dataStore,world) = loadValue storekey dataStore world
	= (mbValue,{TSt|tst&dataStore = dataStore, world = world})
542
where
ecrombag's avatar
ecrombag committed
543
	storekey = "iTask_" +++ (taskNrToString taskNr) +++ "-" +++ key
544

Bas Lijnse's avatar
Bas Lijnse committed
545
getUserUpdates :: !*TSt -> ([(String,String)],!*TSt)
546
getUserUpdates tst=:{taskNr,request} = (updates request, tst);
Bas Lijnse's avatar
Bas Lijnse committed
547 548 549 550 551 552
where
	updates request
		| http_getValue "_targettask" request.arg_post "" == taskNrToString taskNr
			= [u \\ u =:(k,v) <- request.arg_post | k.[0] <> '_']
		| otherwise
			= []
553
			
554 555 556 557 558 559 560
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
		
Bas Lijnse's avatar
Bas Lijnse committed
561 562 563
resetSequence :: !*TSt -> *TSt
resetSequence tst=:{taskNr,tree}
	= case tree of
564
		(TTSequenceTask info sequence)	= {tst & taskNr = [0:tl taskNr], tree = TTSequenceTask info []}
Bas Lijnse's avatar
Bas Lijnse committed
565
		_								= {tst & tree = tree}
Bas Lijnse's avatar
Bas Lijnse committed
566

567
deleteTaskStates :: !TaskNr !*TSt -> *TSt
568 569
deleteTaskStates taskNr tst=:{TSt|dataStore,world}
	# (dataStore,world) = deleteValues (iTaskId taskNr "") dataStore world
570
	= {TSt|tst & world = world, dataStore = dataStore} 
571
	
572
copyTaskStates :: !TaskNr !TaskNr !*TSt	-> *TSt
ecrombag's avatar
ecrombag committed
573 574 575
copyTaskStates fromtask totask tst=:{TSt|dataStore,world}
	# (dstore,world) = copyValues (iTaskId fromtask "") (iTaskId totask "") dataStore world
	= {TSt|tst & dataStore = dstore, world = world}
576 577

flushStore :: !*TSt -> *TSt
578
flushStore tst=:{TSt|dataStore,systemStore,documentStore,world}
ecrombag's avatar
ecrombag committed
579 580
	# (dstore,world) = flushCache dataStore world
	# (sstore,world) = flushCache systemStore world
581 582
	# (fstore,world) = flushCache documentStore world
	= {TSt|tst & dataStore = dstore, systemStore = sstore, documentStore = fstore, world = world}
583

584 585 586
taskNrToString :: !TaskNr -> String
taskNrToString [] 		= ""
taskNrToString [i] 		= toString i
587
taskNrToString [i:is] 	= taskNrToString is +++ "." +++ toString i 
588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604

taskNrFromString :: !String -> TaskNr
taskNrFromString "" 		= []
taskNrFromString string	= reverse (parseTaskNr` [char \\ char <-: string])
where
	parseTaskNr` :: ![Char] -> TaskNr
	parseTaskNr` [] = []
	parseTaskNr` list 
	# (front,end)	= span (\c -> c <> '.') list
	=  [toInt (toString  front) : parseTaskNr` (stl end)]

	toString :: [Char] -> String
	toString list = {c \\ c <- list}

	stl :: [Char] -> [Char]
	stl [] = []
	stl xs = tl xs
605

606
taskLabel :: !(Task a) -> String
607
taskLabel (Task desc _ _) = desc.TaskDescription.title