iTasksProcessHandling.icl 20.9 KB
Newer Older
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
1 2 3 4 5 6 7 8 9 10 11
implementation module iTasksProcessHandling

// *********************************************************************************************************************************
// This module contains iTask combinators for creating iTask workflow processes
// *********************************************************************************************************************************
// iTask & iData Concept and Implementation: (c) 2006,2007,2008 - Rinus Plasmeijer
// *********************************************************************************************************************************
//
import StdEnv 
import iDataFormlib
import InternaliTasksCommon, InternaliTasksThreadHandling
12
import iTasksBasicCombinators, iTasksSettings
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
13
import dynamic_string
14
import GenBimap
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
15

16 17 18 19
derive gForm 	Wid, WorkflowStatus, []
derive gUpd 	Wid, WorkflowStatus, []
derive gParse 	Wid, WorkflowStatus
derive gPrint 	Wid, WorkflowStatus
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
20
derive gerda 	Wid, WorkflowStatus
21 22
derive read 	Wid, WorkflowStatus
derive write 	Wid, WorkflowStatus
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
23 24

:: Wid a			= Wid WorkflowLink											// id of workflow process
25 26 27
:: WorkflowProcess 	= ActiveWorkflow 	ProcessIds !(TCl Dynamic)
					| SuspendedWorkflow ProcessIds !(TCl Dynamic)
					| FinishedWorkflow 	ProcessIds !Dynamic !(TCl Dynamic)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
28 29 30 31
					| DeletedWorkflow	ProcessIds

instance == WorkflowStatus
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
32 33
	(==) (WflActive _) 			(WflActive _)  	= True
	(==) (WflSuspended _)  		(WflSuspended _)= True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
34 35 36 37 38 39
	(==) WflFinished    		WflFinished 	= True
	(==) WflDeleted 			WflDeleted		= True
	(==) _ 						_ 				= False

workflowProcessStoreName :== "Application" +++  "-ProcessTable"

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
40 41 42 43
derive gForm	WorkflowProcess
derive gUpd		WorkflowProcess
derive gPrint	WorkflowProcess
derive gParse	WorkflowProcess
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
44
derive gerda	WorkflowProcess	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
45 46
derive read		WorkflowProcess	
derive write	WorkflowProcess	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
47 48 49 50 51 52 53 54 55

gPrint{|Dynamic|} dyn pst 	= gPrint{|*|} (dynamic_to_string dyn) pst
gParse{|Dynamic|} expr 		= case parseString expr of
								(Just string) 	= Just (string_to_dynamic {s` \\ s` <-: string})
								Nothing			= Nothing
where
	parseString :: !Expr -> Maybe String
	parseString expr = gParse{|*|} expr
	
56
gForm{|Dynamic|} (init, formid) hst = ({changed=False,form=[], inputs = [],value=formid.ival},(incrHStCntr 1 hst))
57 58
gUpd{|Dynamic|} (UpdSearch 0 _) a 	= (UpdDone,a)
gUpd{|Dynamic|} (UpdSearch i v) a 	= (UpdSearch (i-1) v,a)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
59 60
gUpd{|Dynamic|} (UpdCreate c) a 	= (UpdCreate c,dynamic 0)
gUpd{|Dynamic|} UpdDone a 			= (UpdDone,a)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
61 62 63 64 65 66 67 68
write{|Dynamic|} dyn pst 	= write{|*|} (dynamic_to_string dyn) pst
read{|Dynamic|} pst 		= case myread pst of
								Read  string i f	= Read (string_to_dynamic {s` \\ s` <-: string}) i f
								Fail f				= Fail f
where
	myread :: !*Write -> *Read .String
	myread pst = read{|*|} pst

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
69 70 71
gerda{|Dynamic|} 	= abort "Cannot yet store a Dynamic in a Database\n" 
gerda{|TCl|} ga		= abort "Cannot yet store an iTask of type TCL in a Database\n" 

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
72 73
import DrupBasic

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
74 75 76 77
isValidWorkflowReference :: !WorkflowProcess !ProcessIds -> Bool								// checks whether pointer to workflow is still refering to to right entry in the table
isValidWorkflowReference workflowprocess idsref = drop1tuple3 (getWorkflowWid workflowprocess) == drop1tuple3 idsref
where
	drop1tuple3 (x,y,z) = (y,z)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
78

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
79
getWorkflowWid :: !WorkflowProcess -> ProcessIds 									// get wid of a process
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
80 81 82 83
getWorkflowWid (ActiveWorkflow 	ids _)			= ids
getWorkflowWid (SuspendedWorkflow ids _)		= ids
getWorkflowWid (FinishedWorkflow 	ids _ _)	= ids
getWorkflowWid (DeletedWorkflow	ids)			= ids
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
84

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
85
getWorkflowUser :: !WorkflowProcess -> UserId										// fetch user who should do the work
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
86 87 88 89 90
getWorkflowUser (ActiveWorkflow 	(userid,_,_) _)		= userid 
getWorkflowUser (SuspendedWorkflow  (userid,_,_) _)		= userid
getWorkflowUser (FinishedWorkflow 	(userid,_,_) _ _)	= userid
getWorkflowUser (DeletedWorkflow	(userid,_,_))		= userid

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
91
setWorkflowUser :: !UserId !WorkflowProcess -> WorkflowProcess						// fetch user who should do the work
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
92 93 94 95 96
setWorkflowUser nuserid (ActiveWorkflow 		(userid,procnr,wflab) task)		= (ActiveWorkflow 		(nuserid,procnr,wflab) task)
setWorkflowUser nuserid (SuspendedWorkflow  	(userid,procnr,wflab) task)		= (SuspendedWorkflow  	(nuserid,procnr,wflab) task)
setWorkflowUser nuserid (FinishedWorkflow 		(userid,procnr,wflab) dyn task)	= (FinishedWorkflow 	(userid,procnr,wflab) dyn task)
setWorkflowUser nuserid (DeletedWorkflow		(userid,procnr,wflab))			= (DeletedWorkflow		(nuserid,procnr,wflab))

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
97
getTask :: !WorkflowProcess -> Task Dynamic
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
98 99 100 101
getTask (ActiveWorkflow 	(_,_,_) (TCl task))		= task 
getTask (SuspendedWorkflow  (_,_,_) (TCl task))		= task
getTask (FinishedWorkflow 	(_,_,_) _ (TCl task))	= task

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
102
isDeletedWorkflow :: !WorkflowProcess -> Bool
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
103 104 105
isDeletedWorkflow (DeletedWorkflow _) = True
isDeletedWorkflow _	= False

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
106
workflowProcessStore ::  !((!Int,![WorkflowProcess]) -> (!Int,![WorkflowProcess])) !*TSt -> (!(!Int,![WorkflowProcess]),!*TSt) 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
107
workflowProcessStore wfs tst	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
108 109 110 111
= IF_Ajax 																		
	(IF_ClientServer															// we running both client and server
		(IF_ClientTasks												
			(abort "Cannot access workflow process table on client\n")			// workflow table only on server site
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
112
			(workflowProcessStore` wfs tst)										// access workflow store
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
113 114 115 116
		)
		(workflowProcessStore` wfs tst)
	)
	(workflowProcessStore` wfs tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
117 118 119
where
	workflowProcessStore` wfs tst=:{hst}	
	# (form,hst) = mkStoreForm (Init, pFormId workflowProcessStoreName (0,[]) <@ NoForm) wfs hst
120
	= (form.Form.value,{tst & hst = hst})
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
121 122

scheduleWorkflows :: !(Task a) -> (Task a) | iData a
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
123
scheduleWorkflows maintask 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
124 125
//# nmaintask	= newTask defaultWorkflowName (mkTask "StartMain" (assignTaskTo 0 ("main",maintask)))
# nmaintask	= assignTaskTo 0 ("main",maintask)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
126 127 128 129
= IF_Ajax 																		
	(IF_ClientServer															// we running both client and server
		(IF_ClientTasks												
			nmaintask															// workflow table only on server site, do only maintask
130
			(Task (scheduleWorkflows` nmaintask))								// access workflow store
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
131
		)
132
		(Task (scheduleWorkflows` nmaintask))
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
133
	)
134
	(Task (scheduleWorkflows` nmaintask))
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
135
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
136
	scheduleWorkflows` nmaintask tst 
137
	# (a,tst=:{activated}) 	= appTaskTSt nmaintask tst	// start maintask
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
138 139 140 141 142 143
	# ((_,wfls),tst) 		= workflowProcessStore id tst												// read workflow process administration
	# (done,tst)			= scheduleWorkflowTable True wfls 0 {tst & activated = True}				// all added workflows processes are inspected (THIS NEEDS TO BE OPTIMIZED AT SOME STAGE)
	= (a,{tst & activated = activated && done})															// whole application ends when all processes have ended

scheduleWorkflowTable done [] _ tst = (done,tst)
scheduleWorkflowTable done [ActiveWorkflow _ (TCl dyntask):wfls] procid tst
144
# (_,tst=:{activated}) = appTaskTSt dyntask {tst & activated = True}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
145 146 147 148
= scheduleWorkflowTable (done && activated) wfls (inc procid) {tst & activated = activated}
scheduleWorkflowTable done [SuspendedWorkflow _ _:wfls] procid tst
= scheduleWorkflowTable done wfls (inc procid) tst
scheduleWorkflowTable done [FinishedWorkflow _ _ (TCl dyntask):wfls] procid tst	// just to show result in trace..
149
# (_,tst) = appTaskTSt dyntask tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
150 151 152 153 154
= scheduleWorkflowTable done wfls (inc procid) tst
scheduleWorkflowTable done [DeletedWorkflow _:wfls] procid tst
= scheduleWorkflowTable done wfls (inc procid) tst

spawnWorkflow :: !UserId !Bool !(LabeledTask a) -> Task (Wid a) | iData a
155
spawnWorkflow userid active (label,task) = Task (\tst=:{options,staticInfo} -> appTaskTSt ((newTask ("spawn " +++ label) (Task (spawnWorkflow` options))<<@ staticInfo.threadTableLoc)) tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
156 157 158 159 160 161
where
	spawnWorkflow` options tst
	# ((processid,wfls),tst) 		
						= workflowProcessStore id tst							// read workflow process administration
	# (found,entry)		= findFreeEntry wfls 1									// found entry in table
	# processid			= processid + 1											// process id currently given by length list, used as offset in list
162
	# wfl				= mkdyntask options entry processid task				// convert user task in a dynamic task
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
163 164 165 166
	# nwfls				= if found 
							(updateAt (entry - 1) (if active ActiveWorkflow SuspendedWorkflow (userid,processid,label) (TCl wfl)) wfls)
							(wfls ++ [if active ActiveWorkflow SuspendedWorkflow (userid,processid,label) (TCl wfl)])				// turn task into a dynamic task
	# (wfls,tst) 		= workflowProcessStore (\_ -> (processid,nwfls)) tst	// write workflow process administration
167
	# (_,tst)			= appTaskTSt (if active wfl (Task (\tst -> (undef,tst)))) tst	// if new workflow is active, schedule it in
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
168 169
	= (Wid (entry,(userid,processid,label)),{tst & activated = True})

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
170
	findFreeEntry :: [WorkflowProcess] Int -> (Bool,Int)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
171 172 173 174 175
	findFreeEntry [] n	= (False,n)
	findFreeEntry [DeletedWorkflow _:wfls] n = (True,n)
	findFreeEntry [_:wfls] n = findFreeEntry wfls (n + 1)

	mkdyntask options entry processid task 
176
	=  Task (\tst -> convertTask entry processid label task 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
177 178 179 180 181 182 183
				{tst & tasknr = [entry - 1],activated = True,userId = userid, options = options,workflowLink = (entry,(userid,processid,label))})
	
	convertTask entry processid label task tst

	# ((processid,wfls),tst) 	= workflowProcessStore id tst					// read workflow process administration
	# wfl						= wfls!!(entry - 1)								// fetch entry
	# currentWorker				= getWorkflowUser wfl							// such that worker can be changed dynamically !
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
184 185
//	# (a,tst=:{activated})		= appTaskTSt (newTask label (mkTask "StartMain" (assignTaskTo currentWorker ("main",task)))) tst			
	# (a,tst=:{activated})		= appTaskTSt (assignTaskTo currentWorker ("main",task)) tst			
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
186 187 188 189 190

	# dyn						= dynamic a
	| not activated				= (dyn,tst)										// not finished, return
	# ((_,wfls),tst) 			= workflowProcessStore id tst					// read workflow process administration
	# wfls						= case (wfls!!(entry - 1)) of					// update process administration
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
191
										(ActiveWorkflow wid acttask) -> updateAt (entry - 1) (FinishedWorkflow wid dyn acttask) wfls
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
192 193 194 195 196
										_ -> wfls
	# (wfls,tst) 				= workflowProcessStore (\_ -> (processid,wfls)) tst		// write workflow process administration
	= (dyn,tst)												

changeWorkflowUser :: !UserId !(Wid a) -> Task Bool 
197
changeWorkflowUser nuser (Wid (entry,ids=:(_,_,label))) = newTask ("changeUser " +++ label) (Task deleteWorkflow`)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
198 199 200 201 202 203 204 205 206 207 208 209 210
where
	deleteWorkflow` tst
	| entry == 0		= (False,tst)											// main task cannot be handled
	# ((maxid,wfls),tst)= workflowProcessStore id tst							// read workflow process administration
	# wfl				= wfls!!(entry - 1)										// fetch entry
	# refok				= isValidWorkflowReference wfl ids
	| not refok			= (False,tst)											// wid does not refer to the correct entry anymore
	# wfl				= setWorkflowUser nuser wfl
	# nwfls				= updateAt (entry - 1) wfl wfls							// delete entry in table
	# (wfls,tst) 		= workflowProcessStore (\_ -> (maxid,nwfls)) tst		// update workflow process administration
	= (True,tst)																// if everything is fine it should always succeed

waitForWorkflow :: !(Wid a) -> Task (Maybe a) | iData a
211
waitForWorkflow (Wid (entry,ids=:(_,_,label))) = newTask ("waiting for " +++ label) (Task waitForResult`)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
212 213 214 215 216
where
	waitForResult` tst
	# ((_,wfls),tst) 	= workflowProcessStore id tst							// read workflow process administration
	# wfl				= wfls!!(entry - 1)										// fetch entry
	# refok				= isValidWorkflowReference wfl ids
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
217
	| not refok			= (Nothing,{tst & activated = True})					// wid does not refer to the correct entry anymore
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
218 219 220 221
	= case wfl of																// update process administration
			(FinishedWorkflow _ (val::a^) _) -> (Just val,{tst & activated = True})	// finished
			_ 					->  (Nothing,{tst & activated = False})	// not yet

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238
/*
waitForWorkflowWithName :: !String -> Task (Maybe a) | iData a
waitForWorkflowWithName labelSearched = newTask ("waiting for " +++ labelSearched) waitForResult`
where
	waitForResult` tst
	# ((_,wfls),tst) 	= workflowProcessStore id tst							// read workflow process administration
	# foundEntries		= [i \\ i <- [0 ..] & wfl <- wfls | thd3 (getWorkflowWid wfl) == labelSearched]
	| isEmpty foundEntries
						= (Nothing,{tst & activated = False})					// entry does not exist
	# entry				= hd foundEntries										// entry found; first entry is taken
	# wfl				= wfls!!(entry - 1)										// fetch entry
	= case wfl of																// update process administration
			(FinishedWorkflow _ (val::a^) _) -> (Just val,{tst & activated = True})	// finished
			_ 					->  (Nothing,{tst & activated = False})			// not yet
*/

waitForWorkflowWid :: !String -> Task (Maybe (Wid a)) | iData a
239
waitForWorkflowWid labelSearched = newTask ("waiting for " +++ labelSearched) (Task waitForResult`)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
240 241 242 243 244 245 246 247 248 249 250 251
where
	waitForResult` tst
	# ((_,wfls),tst) 	= workflowProcessStore id tst							// read workflow process administration
	# foundEntries		= [i \\ i <- [1 ..] & wfl <- wfls | thd3 (getWorkflowWid wfl) == labelSearched]
	| isEmpty foundEntries
// set True as experiment...
						= (Nothing,{tst & activated = True})					// entry does not (yet) exist
	| length foundEntries <> 1
						= (Nothing,{tst & activated = True})					// there are more; illegal action; it is assumed that there is only one
	# entry				= hd foundEntries
	= (Just (Wid (entry,getWorkflowWid (wfls!!(entry - 1)))),{tst & activated = True})						// entry found

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
252
deleteMe :: (Task Void)
253
deleteMe = Task deleteMe`
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
254 255
where
	deleteMe` tst=:{workflowLink} 
256
	=	appTaskTSt (				deleteWorkflow (Wid workflowLink)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
257 258 259
			=>> \_ ->	return_V Void ) tst

deleteWorkflow :: !(Wid a) -> Task Bool 
260
deleteWorkflow (Wid (entry,ids=:(_,_,label))) = newTask ("delete " +++ label) (Task deleteWorkflow`)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
261 262 263 264 265 266 267 268 269 270
where
	deleteWorkflow` tst
	| entry == 0		= (False,tst)											// main task cannot be handled
	# ((maxid,wfls),tst)= workflowProcessStore id tst							// read workflow process administration
	# wfl				= wfls!!(entry - 1)										// fetch entry
	# refok				= isValidWorkflowReference wfl ids						// does the Wid indeed refers to this process
	| not refok			= (False,tst)											// wid does not refer to the correct entry anymore
	| isDeletedWorkflow wfl = (True,tst)										// already deleted
	# nwfls				= updateAt (entry - 1) (DeletedWorkflow ids) wfls		// delete entry in table
	# (wfls,tst=:{html}) = workflowProcessStore (\_ -> (maxid,nwfls)) tst		// update workflow process administration
271
	# (_,tst)			= appTaskTSt (getTask wfl) {tst & html = BT [] []}					// calculate workflow to delete for the last time to obtain all its itasks in the task tree
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
272
	# tst				= deleteSubTasksAndThreads [entry] tst					// delete all iTask storage of this process ...
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
273
	= (True,{tst & html = html, activated = True})												// if everything is fine it should always succeed
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
274 275

suspendMe :: (Task Void)
276
suspendMe = Task suspendMe`
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
277 278 279
where
	suspendMe` tst=:{workflowLink = workflowLink=:(entry,ids)} 
	| entry == 0		= (Void,tst)											// main task cannot be handled
280
	= appTaskTSt (	suspendWorkflow (Wid workflowLink)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
281 282 283
			=>> \_ ->	return_V Void ) tst

suspendWorkflow :: !(Wid a) -> Task Bool
284
suspendWorkflow (Wid (entry,ids=:(_,_,label))) = newTask ("suspend " +++ label) (Task deleteWorkflow`)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300
where
	deleteWorkflow` tst
	| entry == 0		= (False,tst)											// main task cannot be handled
	# ((maxid,wfls),tst)= workflowProcessStore id tst							// read workflow process administration
	# wfl				= wfls!!(entry - 1)										// fetch entry
	# refok				= isValidWorkflowReference wfl ids
	| not refok			= (False,tst)											// wid does not refer to the correct entry anymore
	# (ok,nochange,wfl)	= case wfl of
							(ActiveWorkflow label acttask) -> (True,False,SuspendedWorkflow label acttask)
							(DeletedWorkflow label) -> (False,True,DeletedWorkflow label) // a deleted workflow cannot be suspendend
							wfl -> (True,True,wfl)								// in case of finsihed or already suspended flows
	| nochange			= (ok,{tst & activated = True})							// no change needed
	# nwfls				= updateAt (entry - 1) wfl wfls							// update entry
	# (wfls,tst) 		= workflowProcessStore (\_ -> (maxid,nwfls)) tst		// update workflow process administration
	= (ok,tst)																	// if everything is fine it should always succeed

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
301
activateWorkflow :: !(Wid a) -> Task Bool
302
activateWorkflow (Wid (entry,ids=:(_,_,label))) = newTask ("activate " +++ label) (Task activateWorkflow`)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
303 304 305 306 307 308 309 310 311 312 313 314 315 316 317
where
	activateWorkflow` tst
	| entry == 0		= (False,tst)											// main task cannot be handled
	# ((maxid,wfls),tst)= workflowProcessStore id tst							// read workflow process administration
	# wfl				= wfls!!(entry - 1)										// fetch entry
	# refok				= isValidWorkflowReference wfl ids
	| not refok			= (False,tst)											// wid does not refer to the correct entry anymore
	= case wfl of
		(SuspendedWorkflow label susptask) -> scheduleWorkflow label maxid susptask wfls tst
		(ActiveWorkflow    label acttask)  -> (True,{tst & activated = True})
		wfl -> (False,{tst & activated = True})									// in case of finished or deleted task

	scheduleWorkflow label maxid (TCl wfl) wfls tst										
	# nwfls				= updateAt (entry - 1) (ActiveWorkflow label (TCl wfl)) wfls // mark workflow as activated
	# (wfls,tst) 		= workflowProcessStore (\_ -> (maxid,nwfls)) tst		// update workflow process administration
318
	# (_,tst)			= appTaskTSt wfl {tst & activated = True}				// schedule workflow
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
319 320 321 322
	= (True,tst)																// done


/*
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
323 324 325 326 327 328 329 330 331 332 333
activateWorkflow :: !(Wid a) -> Task Bool
activateWorkflow (Wid (entry,ids=:(_,_,label))) = newTask ("activate " +++ label) activateWorkflow`
where
	activateWorkflow` tst
	| entry == 0		= (False,tst)											// main task cannot be handled
	# ((maxid,wfls),tst)= workflowProcessStore id tst							// read workflow process administration
	# wfl				= wfls!!(entry - 1)										// fetch entry
	# refok				= isValidWorkflowReference wfl ids
	| not refok			= (False,tst)											// wid does not refer to the correct entry anymore
	# (ok,nochange,wfl,tst)	
						= case wfl of
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
334 335
								(SuspendedWorkflow label susptask) -> scheduleWorkflow label susptask tst
//								(DeletedWorkflow label) -> (False,True,DeletedWorkflow label,tst) // a deleted workflow cannot be suspendend
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
336 337 338 339 340 341
								wfl -> (True,True,wfl,tst)						// in case of finished or already activated flows
	| nochange			= (ok,{tst & activated = True})							// no change needed
	# nwfls				= updateAt (entry - 1) wfl wfls							// update entry
	# (wfls,tst) 		= workflowProcessStore (\_ -> (maxid,nwfls)) tst		// update workflow process administration
	= (ok,tst)																	// if everything is fine it should always succeed

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
342
	scheduleWorkflow label (TCl wfl) tst										// schedule workflow
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
343 344 345
	# (_,tst)	= wfl {tst & activated = True}
	= (True,False,ActiveWorkflow label (TCl wfl),{tst & activated = True})

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
346
*/
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
347
getWorkflowStatus :: !(Wid a) -> Task WorkflowStatus
348
getWorkflowStatus (Wid (entry,ids=:(_,_,label))) = newTask ("get status " +++ label) (Task getWorkflowStatus`)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
349 350 351 352 353 354 355
where
	getWorkflowStatus` tst
	# ((_,wfls),tst) 	= workflowProcessStore id tst							// read workflow process administration
	# wfl				= wfls!!(entry - 1)										// fetch entry
	# refok				= isValidWorkflowReference wfl ids
	| not refok			= (WflDeleted,tst)										// wid does not refer to the correct entry anymore
	# status			= case wfl of
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
356 357 358 359
							(ActiveWorkflow (user,_,_) _) 		-> WflActive user
							(SuspendedWorkflow (user,_,_) _) 	-> WflSuspended user
							(FinishedWorkflow _ _ _) 			-> WflFinished
							(DeletedWorkflow _) 				-> WflDeleted		
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
360 361
	= (status,tst)																// if everything is fine it should always succeed

362
showWorkflows :: !Bool !*TSt -> ([HtmlTag],*TSt)
363
showWorkflows alldone tst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
364 365 366 367 368 369 370 371 372
= 	IF_ClientTasks												
		(\tst -> ([],tst))														// workflow table not available on clients
		(showWorkflows` alldone) tst											// show tables
where
	showWorkflows` alldone tst
	# ((_,wfls),tst) 		= workflowProcessStore id tst						// read workflow process administration
	= (mkTable wfls,tst)

	mkTable []		= []
373 374 375 376 377 378 379 380 381 382 383 384 385

	mkTable wfls	= [DivTag [IdAttr "itasks-workflow-process-table",ClassAttr "trace"] [H2Tag [] [Text "Workflow Process Table:"], TableTag [] [header : rows]]]
	where
		header	= TrTag [] 
					[   ThTag [] [Text "Entry"], 		ThTag [] [Text "User Id"],  ThTag [] [Text "Process Id"],  ThTag [] [Text "Task Name"], 		 ThTag [] [Text "Status"]]
		rows	= 	[	TrTag [] [TdTag [] [Text "0"],  TdTag [] [Text "0"], 		TdTag [] [Text "0"], 		   TdTag [] [Text defaultWorkflowName], TdTag [] [if alldone (Text "Finished") (Text "Active")]]
					: [ TrTag [] [TdTag [] [Text (toString i)]: showStatus wfl] \\ wfl <- wfls & i <- [1..]]
					]

	showStatus (ActiveWorkflow 	 	(userid,processid,label) dyntask)		= [TdTag [] [Text (toString userid)], TdTag [] [Text (toString processid)], TdTag [] [Text label], TdTag [] [Text "Active"]]
	showStatus (SuspendedWorkflow 	(userid,processid,label) dyntask)		= [TdTag [] [Text (toString userid)], TdTag [] [Text (toString processid)], TdTag [] [Text label], TdTag [] [Text "Suspended"]]
	showStatus (FinishedWorkflow 	(userid,processid,label) dyn dyntask)	= [TdTag [] [Text (toString userid)], TdTag [] [Text (toString processid)], TdTag [] [Text label], TdTag [] [Text "Finished"]]
	showStatus (DeletedWorkflow  	(userid,processid,label))				= [TdTag [] [Text (toString userid)], TdTag [] [Text (toString processid)], TdTag [] [Text label], TdTag [] [Text "Deleted"]]
386 387 388 389 390

	STable atts table		= TableTag atts (mktable table)
	where
		mktable table 	= [TrTag [] (mkrow rows)           \\ rows <- table]
		mkrow   rows 	= [TdTag [ValignAttr "top"]  [row] \\ row  <- rows ]