iTasks.icl 109 KB
Newer Older
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
1 2
implementation module iTasks

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
3
// (c) iTask & iData Concept and Implementation by Rinus Plasmeijer, 2006-2008 - MJP
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
4 5 6

// iTasks library for defining interactive multi-user workflow tasks (iTask) for the web.
// Defined on top of the iData library.
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
7

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
8
import StdEnv, StdBimap, StdOrdList
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
9
import iDataSettings, iDataHandler, iDataTrivial, iDataButtons, iDataFormlib, iDataStylelib
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
10
import dynamic_string, graph_to_string_with_descriptors, graph_to_sapl_string
11
import DrupBasic
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
12
import iTasksSettings
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
13

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
14
derive gForm 	Void, Options, Lifespan, Mode, StorageFormat, GarbageCollect, GlobalInfo, TaskThread, ThreadKind, Wid, WorkflowStatus, Maybe, []
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
15 16 17 18 19 20
derive gUpd 	Void, Options, Lifespan, Mode, StorageFormat, GarbageCollect, GlobalInfo, TaskThread, ThreadKind, Wid, WorkflowStatus, Maybe, []
derive gParse 	Void, Options, Lifespan, Mode, StorageFormat, GarbageCollect, GlobalInfo, TaskThread, ThreadKind, Wid, WorkflowStatus, Maybe
derive gPrint 	Void, Options, Lifespan, Mode, StorageFormat, GarbageCollect, GlobalInfo, TaskThread, ThreadKind, Wid, WorkflowStatus, Maybe
derive gerda 	Void, Options, Lifespan, Mode, StorageFormat, GarbageCollect, GlobalInfo, TaskThread, ThreadKind, Wid, WorkflowStatus
derive read 	Void, Options, Lifespan, Mode, StorageFormat, GarbageCollect, GlobalInfo, TaskThread, ThreadKind, Wid, WorkflowStatus
derive write 	Void, Options, Lifespan, Mode, StorageFormat, GarbageCollect, GlobalInfo, TaskThread, ThreadKind, Wid, WorkflowStatus
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
21

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
22 23 24
:: *TSt 		=	{ tasknr 		:: !TaskNr			// for generating unique form-id's
					, activated		:: !Bool   			// if true activate task, if set as result task completed	
					, userId		:: !Int				// id of user to which task is assigned
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
25
					, workflowName	:: !WorkflowName	// wid and name of the workflow process a task is part of
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
26
					, staticInfo	:: !StaticInfo		// info which does not change during a run
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
27 28 29 30
					, html			:: !HtmlTree		// accumulator for html code
					, options		:: !Options			// iData lifespan and storage format
					, trace			:: !Maybe [Trace]	// for displaying task trace
					, hst			:: !HSt				// iData state
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
31
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
32
:: UserId		:== !Int
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
33
:: TaskNr		:== [Int]								// task nr i.j is adminstrated as [j,i]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
34 35 36 37 38 39
:: WorkflowName	:== !(WorkflowId,WorkflowLabel)			// wid and name of the workflow process a task is part of
:: WorkflowId	:== !Int
:: WorkflowLabel:== !String
:: HtmlTree		=	BT HtmlCode							// simple code
				|	(@@:) infix  0 TaskName HtmlTree	// code with id of user attached to it
				|	(-@:) infix  0 UserId 	HtmlTree	// skip code with this id if it is the id of the user 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
40 41
				|	(+-+) infixl 1 HtmlTree HtmlTree	// code to be placed next to each other				
				|	(+|+) infixl 1 HtmlTree HtmlTree	// code to be placed below each other				
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
42
				|	DivCode String HtmlTree				// code that should be labeled with a div, used for Ajax and Client technology
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
43
:: TaskName		:== !(UserId,WorkflowName,!TaskLabel)	// id of user, workflow process name, task name
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
44 45 46 47
:: Options		=	{ tasklife		:: !Lifespan		// default: Session		
					, taskstorage	:: !StorageFormat	// default: PlainString
					, taskmode		:: !Mode			// default: Edit
					, gc			:: !GarbageCollect	// default: Collect
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
48
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
49
:: StaticInfo	=	{ currentUserId	:: UserId			// id of application user 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
50 51
					, threadTableLoc:: !Lifespan		// where to store the server thread table, default is Session
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
52
:: GarbageCollect =	Collect | NoCollect
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
53
:: Trace		=	Trace !TraceInfo ![Trace]			// traceinfo with possibly subprocess
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
54
:: TraceInfo	:== Maybe (!Bool,!(!UserId,!TaskNr,!Options,!String,!String))	// Task finished? who did it, task nr, task name (for tracing) value produced
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
55

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
56
:: ThreadTable	:== [TaskThread]						// thread table is used for Ajax and OnClient options
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
57
:: TaskThread	=	{ thrTaskNr			:: !TaskNr		// task number to recover
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
58 59
					, thrUserId			:: !UserId		// which user has to perform the task
					, thrWorkflowName	:: !WorkflowName// what was the name of workflow process it was part off
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
60 61 62
					, thrOptions		:: !Options		// options of the task
					, thrCallback		:: !String		// serialized callback function for the server
					, thrCallbackClient	:: !String		// serialized callback function for the client (optional, empty if not applicable)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
63
					, thrKind			:: !ThreadKind 	// kind of thread
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
64
					, thrVersionNr		:: !Int			// version number of application when thread was created
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
65
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
66 67 68
:: ThreadKind	=	ServerThread						// Thread which can only be executed on Server
				|	ClientServerThread					// Thread preferably to be executed on Client, but also runs on Server
				|	ClientThread						// Thread which can only be executed on the Client 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
69
				|	ExceptionHandler					// Exception handler only works on server
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
70
				|	AnyThread							// Used for garbage collection
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
71
:: GlobalInfo	=	{ versionNr			:: !Int			// latest querie number of a user
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
72 73 74
					, newThread			:: !Bool		// is a new thread assigned to this user (used for Ajax)?
					, deletedThreads	:: ![TaskNr]	// are there threads deleted (used for Ajax)?
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
75 76 77 78 79
:: UserStartUpOptions
				= 	{ traceOn			:: !Bool			
					, threadStorageLoc	:: !Lifespan		
					, showUsersOn		:: !Maybe Int	
					, versionCheckOn	:: !Bool
80
					, headerOff			:: !Maybe HtmlCode
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
81
					, testModeOn		:: !Bool
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
82
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
83
:: Wid a			= Wid WorkflowName					// id of workflow process
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
84 85 86 87
:: WorflowProcess 	= ActiveWorkflow 	!(!UserId,!WorkflowLabel) !(TCl Dynamic)
					| SuspendedWorkflow !(!UserId,!WorkflowLabel) !(TCl Dynamic)
					| FinishedWorkflow 	!(!UserId,!WorkflowLabel) !Dynamic !(TCl Dynamic)
					| DeletedWorkflow	!(!UserId,!WorkflowLabel)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
88

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
89
// Initial values
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
90

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
91
defaultUser			:== 0								// default id of user
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
92 93
defaultWorkflowName :== "start"							// name of initial workflow process
defaultWid			:== 0								// initial workflow process id
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
94

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
95
initTst :: UserId !Lifespan !*HSt -> *TSt
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
96
initTst thisUser location hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
97 98
				=	{ tasknr		= [-1]
					, activated 	= True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
99
					, staticInfo	= initStaticInfo thisUser location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
100
					, userId		= if (thisUser >= 0) defaultUser thisUser
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
101
					, workflowName	= (defaultWid,defaultWorkflowName)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
102 103 104 105 106
					, html 			= BT []
					, trace			= Nothing
					, hst 			= hst
					, options 		= initialOptions
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
107

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
108
initialOptions :: Options
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
109 110 111 112 113
initialOptions	=	{ tasklife 		= Session
					, taskstorage 	= PlainString
					, taskmode 		= Edit 
					, gc			= Collect
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
114 115

initStaticInfo :: UserId !Lifespan -> StaticInfo
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
116
initStaticInfo thisUser location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
117
=					{ currentUserId	= thisUser 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
118
					, threadTableLoc= location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
119 120
					}

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
121 122 123
defaultStartUpOptions :: UserStartUpOptions
defaultStartUpOptions
= 	{ traceOn			= True		
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
124
	, threadStorageLoc	= TxtFile				// KLOPT DIT WEL ????		
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
125 126 127
	, showUsersOn		= Just 5	
	, versionCheckOn	= False
	, headerOff			= Nothing
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
128
	, testModeOn		= True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
129 130
	}

131 132 133
// ******************************************************************************************************
// Overloaded Functions on Tasks
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
134

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
135
class 	(<<@) infixl 3 b ::  !(Task a) !b  -> (Task a)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
136
instance <<@  Lifespan
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
where   (<<@) task lifespan			= setTaskLifespan
		where
			setTaskLifespan tst=:{options}
			
			= IF_Ajax 
				(IF_ClientServer															// we running both client and server
					(IF_ClientTasks												
						(if (options.tasklife == Client && (lifespan == TxtFile || lifespan == DataFile || lifespan == Database))
							(abort "Cannot make persistent storage on Client\n")
							(\tst -> task {tst & options.tasklife = lifespan}))						// assign option on client
						(\tst -> task {tst & options.tasklife = lifespan})tst							// assign option on server
					)
					(task {tst & options.tasklife = lifespan})								// assign option on server
				)
				(task {tst & options.tasklife = lifespan}) 									// assign option on server


Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
154 155 156 157 158 159 160
instance <<@  StorageFormat
where   (<<@) task storageformat 	= \tst -> task {tst & options.taskstorage = storageformat}
instance <<@  Mode
where   (<<@) task mode 			= \tst -> task {tst & options.taskmode = mode}
instance <<@  GarbageCollect
where   (<<@) task gc 				= \tst -> task {tst & options.gc = gc}

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
161 162
class 	(@>>) infixl 7 b ::  !b !(Task a)   -> (Task a) | iData a
instance @>>  SubPage
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
163 164
where   (@>>) UseAjax task			= \tst -> IF_Ajax 
												(mkTaskThread UseAjax task tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
165
												(newTask "Ajax Thread Disabled" task tst) 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
166 167
		(@>>) OnClient  task 		= \tst -> IF_Ajax 
												(mkTaskThread OnClient task tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
168
												(newTask "Client Thread Disabled" task tst) 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
169

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
170 171 172 173 174
instance == GarbageCollect
where
	(==) Collect   Collect 		= True
	(==) NoCollect NoCollect 	= True
	(==) _ _ 					= False
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
175 176 177 178 179 180 181 182 183
	
instance == ThreadKind
where
	(==) ServerThread     		ServerThread 	   		= True
	(==) ClientThread    		ClientThread 	   		= True
	(==) ClientServerThread    	ClientServerThread 	   	= True
	(==) ExceptionHandler 		ExceptionHandler		= True
	(==) AnyThread    			_				 	   	= True
	(==) _ 						_ 						= False
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
184

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
185 186 187 188 189 190 191 192 193
instance toString ThreadKind
where
	toString ServerThread     	= "ServerThread"
	toString ClientThread    	= "ClientThread"
	toString ClientServerThread	= "ClientServerThread"
	toString ExceptionHandler 	= "ExceptionHandler"
	toString AnyThread    		= "AnyThread"
	toString _    				= "??? print error in thread"

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
194 195 196 197 198 199 200 201 202 203

determineUserOptions :: ![StartUpOptions] -> UserStartUpOptions		
determineUserOptions startUpOptions = determineUserOptions` startUpOptions defaultStartUpOptions
where
	determineUserOptions` [] 						options = options
	determineUserOptions` [TraceOn:xs] 				options	= determineUserOptions` xs {options & traceOn = True}
	determineUserOptions` [TraceOff:xs] 			options	= determineUserOptions` xs {options & traceOn = False}
	determineUserOptions` [ThreadStorage nloc:xs] 	options = determineUserOptions` xs {options & threadStorageLoc = nloc}
	determineUserOptions` [ShowUsers max:xs] 		options = determineUserOptions` xs {options & showUsersOn = if (max <= 0) Nothing (Just max)}
	determineUserOptions` [VersionCheck:xs] 		options = determineUserOptions` xs {options & versionCheckOn = True}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
204
	determineUserOptions` [NoVersionCheck:xs] 		options = determineUserOptions` xs {options & versionCheckOn = False}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
205
	determineUserOptions` [MyHeader bodytag:xs] 	options = determineUserOptions` xs {options & headerOff = Just bodytag}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
206 207
	determineUserOptions` [TestModeOn:xs] 			options = determineUserOptions` xs {options & testModeOn = True}
	determineUserOptions` [TestModeOff:xs] 			options = determineUserOptions` xs {options & testModeOn = False}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
208

209
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
210
// *** wrappers for the end user, to be used in combination with an iData wrapper...
211
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
212

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
213
singleUserTask :: ![StartUpOptions] !(Task a) !*HSt -> (!Bool,Html,*HSt) | iData a 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
214
singleUserTask startUpOptions maintask hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
215 216
# userOptions			= determineUserOptions startUpOptions
# tst					= initTst 0 userOptions.threadStorageLoc hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
217
# (exception,html,hst)	= startTstTask 0 False (False,[]) userOptions maintask tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
218
= mkHtmlExcep "singleUser" exception html hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
219

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
220
multiUserTask :: ![StartUpOptions] !(Task a) !*HSt -> (!Bool,Html,*HSt) | iData a 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
221
multiUserTask startUpOptions maintask  hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
222
# userOptions 			= determineUserOptions [TestModeOff, VersionCheck, ThreadStorage TxtFile:startUpOptions] 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
223 224 225
# nusers				= case userOptions.showUsersOn of
							Nothing -> 0
							Just n	-> n
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
226
| nusers == 0			= singleUserTask startUpOptions maintask  hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
227 228 229 230 231
# (idform,hst) 			= FuncMenu (Init,nFormId "User_Selected" 
							(0,[("User " +++ toString i,\_ -> i) \\ i<-[0..nusers - 1] ])) hst
# currentWorker			= snd idform.value
# tst					= initTst currentWorker userOptions.threadStorageLoc hst
# (exception,html,hst) 	= startTstTask currentWorker True 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
232
							(if userOptions.traceOn (idform.changed,idform.form) (False,[])) userOptions maintask tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
233
= mkHtmlExcep "multiUser" exception html hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
234

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
235 236
workFlowTask :: ![StartUpOptions] !(Task ((Bool,UserId),a)) !(UserId a -> LabeledTask b) !*HSt -> (!Bool,Html,*HSt) | iData b 
workFlowTask  startUpOptions taska userTask hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
237 238
# userOptions 						= determineUserOptions startUpOptions 
# tst								= initTst -1 userOptions.threadStorageLoc hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
239
# (((new,i),a),tst=:{activated,html,hst})	= taska tst									// for doing the login 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
240 241 242 243 244 245 246
| not activated
	# iTaskHeader					= [showHighLight "i-Task", showLabel " - Multi-User Workflow System ",Hr []]
	# iTaskInfo						= mkDiv "iTaskInfo" [showText "Login procedure... ", Hr []]
	= mkHtmlExcep "workFlow" True [Ajax [ ("thePage",iTaskHeader ++ iTaskInfo ++ noFilter html) // Login ritual cannot be handled by client
										]] hst
# userOptions 						= determineUserOptions [TestModeOff, VersionCheck, ThreadStorage TxtFile:startUpOptions] 
# tst								= initTst i userOptions.threadStorageLoc hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
247
# (exception,body,hst) 				= startTstTask i True (False,[]) userOptions (newUserTask ((new,i),a) <<@ TxtFile) tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
248 249 250 251 252 253 254 255 256 257
= mkHtmlExcep "workFlow" exception body hst
where
	noFilter :: HtmlTree -> HtmlCode
	noFilter (BT body) 			= body
	noFilter (_ @@: html) 		= noFilter html
	noFilter (_ -@: html) 		= noFilter html
	noFilter (htmlL +-+ htmlR) 	= [noFilter htmlL  <=>  noFilter htmlR]
	noFilter (htmlL +|+ htmlR) 	= noFilter htmlL <|.|> noFilter htmlR
	noFilter (DivCode str html) = noFilter html

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
258 259 260 261
	newUserTask ((True,i),a) 	= (spawnWorkflow i True (userTask i a)) =>> \_ -> return_V Void
	newUserTask _ 				= return_V Void


Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
262
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
263
// Main routine for the creation of the workflow page
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
264
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
265

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
266 267
startTstTask :: !Int !Bool  !(!Bool,!HtmlCode) UserStartUpOptions !(Task a) !*TSt -> (!Bool,!HtmlCode,!*HSt) | iData a 
startTstTask thisUser multiuser (userchanged,multiuserform) {traceOn, threadStorageLoc, showUsersOn, versionCheckOn, headerOff, testModeOn} maintask tst=:{hst,tasknr,staticInfo}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
268

269
// prologue
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
270

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
271
# maintask				= activateWorkflows maintask												// force main process to start on tasknr 0.1
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
272

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
273
| thisUser < 0 			= abort "Users should have id's >= 0 !\n"
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
274
# (refresh,hst) 		= simpleButton refreshId "Refresh" id hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
275 276
# (traceAsked,hst) 		= simpleButton traceId "ShowTrace" (\_ -> True) hst
# doTrace				= traceAsked.value False
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
277

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
278
# versionsOn			= IF_ClientTasks False versionCheckOn										// no version control on client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
279 280
# noNewVersion			= not versionsOn || refresh.changed || traceAsked.changed || userchanged 	// no version control in these cases
# (appversion,hst)	 	= setAppversion inc hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
281
# (pversion,hst)	 	= setPUserNr thisUser id hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
282 283 284
# (sversion,hst)	 	= setSVersionNr thisUser id hst
# versionconflict		= sversion > 0 && sversion < pversion.versionNr && not noNewVersion 		// test if there is a version conflict				

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
285 286
# iTaskHeader			=	[Table [Tbl_Width (Percent 100)] [Tr [] 
							[ Td [] [Img [Img_Src (ThisExe +++ "/scleanlogo.jpg"),Img_Align Alo_Middle]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
287
									,showHighLight " i -Task", showLabel " Workflow System "]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
288 289
							, Td [Td_Align Aln_Right] (multiuserform ++ refresh.form ++ ifTraceOn traceAsked.form)] ]]++
							[Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
290
| versionconflict	 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
291
	# iTaskInfo			= mkDiv "iTaskInfo" [showLabel "Cannot apply request. Version conflict. Please refresh the page!", Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
292
	= (True,[Ajax 	[ ("thePage",iTaskHeader ++ iTaskInfo)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
293
						]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
294
				],hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
295 296


Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
297 298
// Here the iTask starts...
													    
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
299
# ((toServer,thrOwner,event,thrinfo,threads),tst=:{html,hst,trace,activated})	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
300
						= (IF_Ajax (startAjaxApplication thisUser pversion) startMainTask)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
301
							maintask {tst & hst = hst, trace = if doTrace (Just []) Nothing, activated = True, html = BT []}
302

303
// epilogue
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
304 305

# newUserVersionNr		= 1 + if (pversion.versionNr > sversion) pversion.versionNr sversion					// increment user querie version number
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
306
# (_,hst)				= clearIncPUser thisUser (\_ -> newUserVersionNr) hst									// store in session
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
307
# (sversion,hst)	 	= setSVersionNr thisUser (\_ -> newUserVersionNr) hst									// store in persistent memory
308

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
309
# showCompletePage		= IF_Ajax (hd threads == [-1]) True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
310
# (threadtrace,tst=:{hst})	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
311
						= if TraceThreads showThreadTable nilTable {tst & hst = hst} 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
312
# threadsText			= if showCompletePage "" (foldl (+++) "" [showThreadNr tasknrs +++ " + " \\ tasknrs <- reverse threads])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
313
# (processadmin,hst)	= showWorkflows activated hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
314
# (threadcode,taskname,mainbuts,subbuts,seltask,hst)	
315
						= Filter showCompletePage thrOwner html hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
316 317

# iTaskInfo				= 	mkDiv "iTaskInfo" 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
318 319 320 321 322
							case headerOff of
								Nothing ->
									(	IF_Ajax (IF_ClientServer (IF_ClientTasks [showLabel "Client: "] [showLabel "Server: "]) []) [] ++
										if multiuser 
											[showText "User: " , showLabel thisUser, showText " - "] [] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
323 324 325
										if (thrinfo == "" ) [] [showLowLight thrinfo, showText " - "] ++
										if (multiuser && versionsOn)
											 [showText "Query " , showTrace ((sversion +++> " / " )<+++ appversion)] [] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
326 327 328 329 330 331 332
										IF_Ajax
											( [showText " - Task#: ", showTrace (showTaskNr  event)] ++
											  if (isNil threads || showCompletePage) [] [showText " - Thread(s)#: ", showTrace threadsText]
											 ) [] ++
										[Br,Hr []]
									)
								Just userInfo -> userInfo
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
333
# iTaskTraceInfo		=	showOptions staticInfo.threadTableLoc ++ processadmin ++ threadtrace ++ [printTrace2 trace ]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
334
| showCompletePage		=	(toServer,[Ajax [("thePage",	iTaskHeader ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
335 336 337
															iTaskInfo  ++
															if (doTrace && traceOn)
																	iTaskTraceInfo
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
338 339
																	[	leftright taskname subbuts,Hr []
																		, mainbuts <=>  seltask
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
340
																	]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
341 342
											)]
									] 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
343
							,hst)
344
# (newthread,oldthreads)=	(hd threads, tl threads)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
345
| otherwise				=	(toServer,[Ajax (	[("iTaskInfo", iTaskInfo)] ++			// header ino
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
346
											[(showTaskNr childthreads,[showText " "]) \\ childthreads <- oldthreads] ++ //clear childthreads, since parent thread don't need to be on this page
347
											[(showTaskNr newthread, if (isNil threadcode) seltask threadcode)]	// task info
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
348 349
										   )
									]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
350
							,hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
351
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
352 353 354 355 356
//	wrap maintask = activateWorkflows (newTask "main" (assignTaskTo False 0 ("main",maintask)))				
//	where
//		clearIStore hst=:{world}								/* would be nice but don't know how to clear this */
//		# world = if testModeOn deleteAllStateFiles id world
//		= (Void,{hst & world = world})
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
357

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
358 359 360 361 362
	leftright left right 
	=	Table [Tbl_Width (Percent 100)] 
			[Tr []	[ Td [] left
					, Td [Td_Align Aln_Right] right]
					]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
363

364 365
	nilTable tst = 	([],tst)

366
	startMainTask :: !(Task a) !*TSt -> ((!Bool,!Int,!TaskNr,!String,![TaskNr]),*TSt) 	// No threads, always start from scratch		
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
367
	startMainTask task tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
368 369
	# (_,tst=:{activated}) = task tst
	= ((True,defaultUser,[0],if activated "iTask application has ended" "",[]),{tst & activated = activated})
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
370

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
371 372
	mbUpdate True _ = id
	mbUpdate _ f = f
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
373

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
374 375
	ifTraceOn form = if traceOn form []

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
376
	showOptions location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
377 378
	= [showText "Version nr: ", showTrace iTaskVersion] ++
	  [showText " - Enabled: "] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
379 380 381 382
	  [showTrace (IF_Ajax 	(" + Ajax (" <+++ location <+++ ") ") "")] ++
	  [showTrace (IF_ClientServer	(IF_Ajax " + Client" "") "")] ++
	  [showTrace (IF_Database " + Database" "")] ++
	  [showTrace (IF_DataFile " + DataFile" "")] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
383
	  [showText " - Disabled: "] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
384 385 386 387
	  [showTrace (IF_Ajax 	"" " - Ajax " )] ++
	  [showTrace (IF_ClientServer	"" " - Client" )] ++
	  [showTrace (IF_Database "" " - Database" )] ++
	  [showTrace (IF_DataFile "" " - DataFile" )] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
388 389 390
	  [Br,Hr []]


391
	mkSTable2 :: [HtmlCode] -> BodyTag
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
392 393 394 395 396 397
	mkSTable2 table
	= Table []	(mktable table)
	where
		mktable table 	= [Tr [] (mkrow rows) \\ rows <- table]	
		mkrow rows 		= [Td [Td_VAlign Alo_Top] [row] \\ row <- rows] 

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
398
	Filter :: !Bool !UserId !HtmlTree !*HSt -> *(![BodyTag],![BodyTag],![BodyTag],![BodyTag],![BodyTag],!*HSt)
399 400
	Filter wholepage thrOwner tree hst
	# startuser			= if wholepage defaultUser thrOwner
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
401 402 403 404 405 406 407 408
	# (threadcode,accu) = Collect thisUser startuser [] ((startuser,(defaultWid,defaultWorkflowName),"main") @@: tree)  // KLOPT DIT WEL ??
	| isNil accu		= (threadcode,[],[],[],[],hst)
	# accu				= sortBy (\((i,_),_,_) ((j,_),_,_) -> i < j) accu
	# (workflownames,subtasks) 						= unziptasks accu
	# ((mainSelected,mainButtons,chosenMain),hst) 	= mkTaskButtons True ("User " <+++ thisUser) thisUser [] initialOptions workflownames hst 
	# (subtasksnames,tcode)							= unzipsubtasks (subtasks!!mainSelected)
	# ((taskSelected,subButtons,chosenTask),hst) 	= mkTaskButtons False ("User " <+++ thisUser <+++ "subtask" <+++ mainSelected) 
																							thisUser [] initialOptions subtasksnames hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
409
	# subButtons		= if (length subtasksnames > 1) subButtons []
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
410
	= (threadcode,[showMainLabel chosenMain, showTrace " / ", showLabel chosenTask],mainButtons,subButtons,tcode!!taskSelected,hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
411 412 413 414 415 416 417 418 419 420 421 422 423 424 425
	where
		unziptasks [] 			= ([],[])
		unziptasks all=:[((wid,wlabel),tlabel,tcode):tasks] 
		# (wsubtask,other) 		= span (\((mwid,_),_,_) ->  mwid == wid) all 
		# (wlabels,wsubtasks)	= unziptasks other
		= ([wlabel:wlabels],[wsubtask:wsubtasks])

		unzipsubtasks []		= ([],[])
		unzipsubtasks [(_,tlabel,tcode):subtasks]		
		# (labels,codes)		= unzipsubtasks subtasks
		= ([tlabel:labels],[tcode:codes])

	Collect :: !UserId !UserId [(WorkflowName,TaskLabel,[BodyTag])] !HtmlTree -> (![BodyTag],![(WorkflowName,TaskLabel,[BodyTag])])
	Collect thisuser taskuser accu ((ntaskuser,workflowName,taskname) @@: tree) 	// Collect returns the wanted code, and the remaining code
	# (myhtml,accu)	= Collect thisuser ntaskuser accu tree							// Collect all code of this user belonging to this task
426
	| thisuser == ntaskuser && not (isNil myhtml)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
427
							= ([],[(workflowName,taskname,myhtml):accu])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
428
	| otherwise				= ([],accu)
429 430 431
	Collect thisuser taskuser accu (nuser -@: tree)
	| thisuser == nuser 	= ([],accu)
	| otherwise				= Collect thisuser taskuser accu tree
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
432 433 434 435 436 437 438 439
	Collect thisuser taskuser accu (tree1 +|+ tree2)
	# (lhtml,accu)	= Collect thisuser taskuser accu tree1
	# (rhtml,accu)	= Collect thisuser taskuser accu tree2
	= (lhtml <|.|> rhtml,accu)
	Collect thisuser taskuser accu (tree1 +-+ tree2)
	# (lhtml,accu)	= Collect thisuser taskuser accu tree1
	# (rhtml,accu)	= Collect thisuser taskuser accu tree2
	= ([lhtml <=> rhtml],accu)
440 441
	Collect thisuser taskuser accu (BT bdtg)
	| thisuser == taskuser	= (bdtg,accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
442
	| otherwise				= ([],accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
443 444
	Collect thisuser taskuser accu (DivCode id tree)
	# (html,accu)			= Collect thisuser taskuser accu tree
445 446
	| thisuser == taskuser 	= (mkDiv id html,accu)
	= ([],accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
447

448
	showThreadTable :: *TSt -> (HtmlCode,*TSt)	// watch it: the actual threadnumber stored is one level deaper, so [-1:nr] instead of nr !!
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
449 450
	showThreadTable tst=:{staticInfo}
	# thisUser		= staticInfo.currentUserId
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
451
	# (tableS,tst)	= ThreadTableStorage id tst													// read thread table from server
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
452
	# tableS		= sortBy (\e1=:{thrTaskNr = t1} e2=:{thrTaskNr =t2} = t1 < t2) tableS
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
453
	# (tableC,tst)	= IF_ClientServer
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
454
						(\tst -> ClientThreadTableStorage id tst)								// read thread table from client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
455
						(\tst -> ([],tst)) tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
456 457
	
	# tableC		= sortBy (\e1=:{thrTaskNr = t1} e2=:{thrTaskNr =t2} = t1 < t2) tableC
458 459
	# bodyS			= 	if (isNil tableS)
						[]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
460
						[showLabel "Server Thread Table: ",
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
461 462
						STable []	(   [[showTrace "UserNr:", showTrace "Kind:", showTrace "TaskNr:", showTrace "Created:"
										 ,showTrace "Storage"]] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
463 464 465 466 467
										[	[ showText (toString entry.thrUserId)
											, showText (toString entry.thrKind)
											, showText (showThreadNr entry.thrTaskNr)
											, showText (toString entry.thrVersionNr)
											, showText (toString entry.thrOptions.tasklife)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
468 469 470
											] 
											\\ entry <- tableS
										]
471 472
									),
						Hr []
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
473
						]
474 475
	# bodyC			= if (isNil tableC)
						[]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
476
						[showLabel ("Client User " +++ toString thisUser +++ " Thread Table: "),
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
477 478
						STable []	(   [[showTrace "UserNr:", showTrace "Kind:", showTrace "TaskNr:", showTrace "Created:"
										 ,showTrace "Storage"]] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
479 480 481 482 483
										[	[ showText (toString entry.thrUserId)
											, showText (toString entry.thrKind)
											, showText (showThreadNr entry.thrTaskNr)
											, showText (toString entry.thrVersionNr)
											, showText (toString entry.thrOptions.tasklife)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
484 485 486
											] 
											\\ entry <- tableC
										]
487 488
									),
						Hr []
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
489 490
						]
	= (bodyS ++ bodyC,tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
491

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
492 493
mkTaskButtons :: !Bool !String !Int !TaskNr !Options ![String] *HSt -> ((Int,HtmlCode,String),*HSt)
mkTaskButtons vertical myid userId tasknr info btnnames hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
494 495
# btnsId			= iTaskId userId tasknr (myid <+++ "genBtns")
# myidx				= length btnnames
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
496
//| myidx == 1		= ((0,[],[]),hst)													// no task button if there is only one task to choose from
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
497 498 499 500
# (chosen,hst)		= SelectStore (myid,myidx) tasknr info id hst						// which choice was made in the past
# (buttons,hst)		= SelectButtons Init btnsId info (chosen,btnnames) hst				// create buttons
# (chosen,hst)		= SelectStore (myid,myidx) tasknr info  buttons.value hst			// maybe a new button was pressed
# (buttons,hst)		= SelectButtons Set btnsId info (chosen,btnnames) hst				// adjust look of that button
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
501
= ((chosen,buttons.form,btnnames!!chosen),hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
502
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
503 504 505 506
	SelectButtons init id info (idx,btnnames) hst 
		= if vertical
			(TableFuncBut2 (init,pageFormId info id [[(mode idx n, but txt,\_ -> n)] \\ txt <- btnnames & n <- [0..]]) hst)
			(TableFuncBut2 (init,pageFormId info id [[(mode idx n, but txt,\_ -> n) \\ txt <- btnnames & n <- [0..]]]) hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
507
	but i = iTaskButton i
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
508 509 510 511 512 513 514 515 516

	mode i j
	| i==j = Display

	= Edit

	SelectStore :: !(String,Int) !TaskNr !Options (Int -> Int) *HSt -> (Int,*HSt)
	SelectStore (myid,idx) tasknr info fun hst 
	# storeId 			= iTaskId userId tasknr (myid <+++ "BtnsS" <+++ idx)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
517
	# (storeform,hst)	= mkStoreForm (Init,storageFormId info storeId 0) fun hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
518 519
	= (storeform.value,hst)

520 521 522
// ******************************************************************************************************
// Event handling for Ajax calls and Sapl handling on the client
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
523

524 525 526 527 528 529 530
// The following functions are defined to support "Ajax technologie" and Client site evaluation of i-Tasks.
// To make this possible, a part of the iTask task tree must be assigened to be a thread such that it can be evaluated as a stand-alone i-Task.
// The programmer has to decide which iTask should become a thread.
// For each event (iData triplet), the system will search for the thread to handle it.
// If a thread task is finished, the parent thread task is activated, and so on.
// Any action requiering the calculation of the Task Tree from scratch will be done one the server
// Watch it: the Client cannot create new Server threads
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
531

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
532

533
startFromRoot :: !GlobalInfo !TaskNr ![TaskNr] !String !(Task a) !*TSt -> ((!Bool,!Int,TaskNr,!String,![TaskNr]),*TSt)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
534
startFromRoot versioninfo eventnr tasknrs message maintask tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
535 536
=	IF_ClientServer																// we are running client server
		(IF_ClientTasks
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
537
			(stopClient eventnr tasknrs message)								// client cannot evaluate from root of task tree, give it up
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
538
			(evaluateFromRoot versioninfo eventnr tasknrs message maintask) tst	// sever can evaluate from scratch
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
539
		)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
540
	(evaluateFromRoot versioninfo eventnr tasknrs message maintask tst)			// ajax can evaluate from scratch as well
541 542 543 544 545 546
where
	stopClient :: !TaskNr ![TaskNr]  !String  !*TSt -> ((!Bool,!Int,TaskNr,!String,![TaskNr]),*TSt)
	stopClient eventnr tasknrs message tst
	= ((True,defaultUser,eventnr,message,tasknrs), tst)
	
	evaluateFromRoot :: !GlobalInfo !TaskNr ![TaskNr] !String !(Task a) !*TSt -> ((!Bool,!Int,TaskNr,!String,![TaskNr]),*TSt)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
547
	evaluateFromRoot versioninfo eventnr tasknrs message maintask tst
548
	# tst					= deleteAllSubTasks versioninfo.deletedThreads tst	// delete subtasks being obsolute
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
549
	# (_,tst) 				= maintask tst										// evaluate main application from scratch
550 551 552 553 554
	# tst=:{activated}		= copyThreadTableToClient tst						// copy thread table to client, if applicable
	# message				= if activated "iTask application finished" message
	= (((True,defaultUser,eventnr,message,tasknrs), {tst & activated = activated}))

startAjaxApplication :: !Int !GlobalInfo !(Task a) !*TSt -> ((!Bool,!Int,TaskNr,!String,![TaskNr]),*TSt) 		// determines which threads to execute and calls them..
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
555
startAjaxApplication thisUser versioninfo maintask tst=:{tasknr,options,html,trace,userId}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
556 557 558 559 560 561
# tst					= copyThreadTableFromClient	versioninfo tst				// synchronize thread tables of client and server, if applicable

// first determine whether we should start calculating the task tree from scratch starting at the root

# (mbevent,tst)			= getTripletTaskNrs tst									// see if there are any events, i.e. triplets received
| isNothing mbevent																// no events
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
562
						= startFromRoot versioninfo tasknr [tasknr] "No events, page refreshed" maintask tst			
563 564 565
# event					= fromJust mbevent										// event found
# (table,tst)			= ThreadTableStorage id tst								// read thread table
| isNil table																	// events, but no threads, evaluate main application from scratch
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
566
						= startFromRoot versioninfo event [tasknr] "No threads, page refreshed" maintask tst			
567 568
# (mbthread,tst)		= findParentThread event tst							// look for thread to evaluate
| isNil mbthread																// no thread can be found, happens e.g. when one switches from tasks
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
569
						= startFromRoot versioninfo event [tasknr] "No matching thread, page refreshed" maintask tst			
570 571
# thread 				= hd mbthread											// thread found
| isMember thread.thrTaskNr versioninfo.deletedThreads							// thread has been deleted is some past, version conflict
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
572
	# tst				= copyThreadTableToClient tst							// copy thread table to client
573
	= ((True,defaultUser,event,"Task does not exist anymore, please refresh",[tasknr]), tst)
574
| versioninfo.newThread															// newthread added by someone
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
575
						= startFromRoot versioninfo event [tasknr] "New tasks added, page refreshed" maintask tst			
576
| not (isNil versioninfo.deletedThreads) 										// some thread has been deleted										
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
577
						= startFromRoot versioninfo event [tasknr] "Tasks deleted, page refreshed" maintask tst			
578
| thread.thrUserId <> thisUser													// updating becomes too complicated
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
579
						= startFromRoot versioninfo event [tasknr] ("Thread of user " <+++ thread.thrUserId <+++ ", page refreshed") maintask tst			
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
580 581 582 583 584 585

// ok, we have found a matching thread

# (_,tst=:{activated}) 	= evalTaskThread thread {tst & html = BT []}			// evaluate the thread
| not activated																	// thread / task not yet finished
	# tst				= copyThreadTableToClient tst							// copy thread table to client
586
	= ((False,thisUser,event,"",[thread.thrTaskNr]),tst)						// no further evaluation, aks user for more input
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
587

588
# (mbthread,tst)		= findParentThread (tl thread.thrTaskNr) tst			// look for thread to evaluate
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
589
= doParent mbthread maintask event [thread.thrTaskNr] {tst & html = BT [], options = options}				// more to evaluate, call thread one level higher
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
590
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
591 592
	doParent [] maintask event accu tst											// no more parents of current event, do main task
						= startFromRoot versioninfo event [tasknr:accu] "No more threads, page refreshed" maintask {tst & html = BT []}			
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
593

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
594
	doParent [parent:next] maintask event accu tst								// do parent of current thread
595
	| parent.thrUserId <> thisUser												// updating becomes too complicated
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
596
						= startFromRoot versioninfo event [tasknr:accu] ("Parent thread of user " <+++ parent.thrUserId <+++ ", page refreshed") maintask {tst & html = BT []}			
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
597

598 599
	# (_,tst=:{activated}) 	= evalTaskThread parent {tst & html = BT []}		// start parent
	| not activated																// parent thread not yet finished
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
600
		# tst				= copyThreadTableToClient tst						// copy thread table to client
601
		= ((False,thisUser,event, "",[parent.thrTaskNr:accu]),tst)				// no further evaluation, aks user for more input
602
	# (mbthread,tst)		= findParentThread (tl parent.thrTaskNr) tst		// look for thread to evaluate
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634
	= doParent mbthread maintask event [parent.thrTaskNr:accu] {tst & options = options}// continue with grand parent ...

// ******************************************************************************************************
// Workflow process management
// ******************************************************************************************************

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

derive gForm	WorflowProcess
derive gUpd		WorflowProcess
derive gPrint	WorflowProcess
derive gParse	WorflowProcess

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
	
gForm{|Dynamic|} (init, formid) hst = ({changed=False,form=[],value=formid.ival},(incrHSt 1 hst))
gUpd{|Dynamic|} (UpdSearch _ 0) a 	= (UpdDone,a)
gUpd{|Dynamic|} (UpdSearch v i) a 	= (UpdSearch v (i-1),a)
gUpd{|Dynamic|} (UpdCreate c) a 	= (UpdCreate c,dynamic 0)
gUpd{|Dynamic|} UpdDone a 			= (UpdDone,a)

workflowProcessStore ::  !([WorflowProcess] -> [WorflowProcess]) !*HSt -> (![WorflowProcess],!*HSt) 
workflowProcessStore wfs hst	
# (form,hst) = mkStoreForm (Init, pFormId workflowProcessStoreName [] <@ NoForm) wfs hst
= (form.value,hst)

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
635 636 637
activateWorkflows :: !(Task a) -> (Task a) | iData a
activateWorkflows maintask = activateWorkflows`
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
638
	activateWorkflows` tst=:{hst} 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
639
	# (a,tst=:{activated,hst}) 	= newTask defaultWorkflowName (assignTaskTo False 0 ("main",maintask)) tst	// start maintask
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
640
	# (wfls,hst) 				= workflowProcessStore id hst					// read workflow process administration
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
641
	# (done,tst)				= activateAll True wfls 0 {tst & hst = hst,activated = True}		// all added workflows processes are inspected (THIS NEEDS TO BE OPTIMIZED AT SOME STAGE)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659
	= (a,{tst & activated = activated && done})									// whole application ends when all processes have ended
	where
		activateAll done [] _ tst = (done,tst)
		
		activateAll done [ActiveWorkflow _ (TCl dyntask):wfls] procid tst
		# (_,tst=:{activated}) = dyntask tst
		= activateAll (done && activated) wfls (inc procid) {tst & activated = activated}
		
		activateAll done [SuspendedWorkflow _ _:wfls] procid tst
		= activateAll done wfls (inc procid) tst
		
		activateAll done [FinishedWorkflow _ _ (TCl dyntask):wfls] procid tst	// just to show result in trace..
		# (_,tst) = dyntask tst
		= activateAll done wfls (inc procid) tst
		
		activateAll done [DeletedWorkflow _:wfls] procid tst
		= activateAll done wfls (inc procid) tst

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
660 661
spawnWorkflow :: !UserId !Bool !(LabeledTask a) -> Task (Wid a) | iData a
spawnWorkflow userid active (label,task) = \tst=:{options,staticInfo} -> (newTask ("spawn " +++ label) (spawnWorkflow` options)<<@ staticInfo.threadTableLoc) tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
662 663 664 665 666
where
	spawnWorkflow` options tst=:{hst}
	# (wfls,hst) 		= workflowProcessStore id hst							// read workflow process administration
	# processid			= length wfls + 1										// process id currently given by length list, used as offset in list
	# wfl				= mkdyntask options processid task 						// convert user task in a dynamic task
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
667
	# nwfls				= wfls ++ [if active ActiveWorkflow SuspendedWorkflow (userid,label) wfl]					// turn task into a dynamic task
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
668
	# (wfls,hst) 		= workflowProcessStore (\_ -> nwfls) hst				// write workflow process administration
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
669
	= (Wid (processid,label),{tst & hst = hst, activated = True})
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
670

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
671
	mkdyntask options processid task = TCl (\tst -> convertTask processid label task 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
672
										{tst & tasknr = [processid - 1],activated = active,userId = userid, options = options,workflowName = (processid,label)})
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
673 674
	
	convertTask processid label task tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
675
	# (a,tst=:{hst,activated})		= newTask label (assignTaskTo False userid ("main",task)) tst//newTask label task tst			
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
676 677 678 679
	# dyn							= dynamic a
	| not activated					= (dyn,tst)									// not finished, return
	# (wfls,hst) 					= workflowProcessStore id hst				// read workflow process administration
	# wfls							= case (wfls!!(processid - 1)) of			// update process administration
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
680
											(ActiveWorkflow _ entry) -> updateAt (processid - 1) (FinishedWorkflow (userid,label) dyn entry) wfls
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
681 682 683 684
											_ -> wfls
	# (wfls,hst) 					= workflowProcessStore (\_ -> wfls) hst		// write workflow process administration
	= (dyn,{tst & hst = hst})												

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
685
waitForWorkflow :: !(Wid a) -> Task a | iData a
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
686
waitForWorkflow (Wid (processid,label)) = newTask ("waiting for " +++ label) waitForResult`
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
687
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
688 689 690 691 692 693 694
	waitForResult` tst=:{hst}
	# (wfls,hst) 		= workflowProcessStore id hst							// read workflow process administration
	# (done,val)		= case (wfls!!(processid - 1)) of						// update process administration
								(FinishedWorkflow _ (val::a^) _) -> (True,val)	// finished
								_ -> (False,createDefault)						// not yet
	= (val,{tst & hst = hst, activated = done})									// return value and release when done

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
695
deleteWorkflow :: !(Wid a) -> Task Bool 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
696
deleteWorkflow (Wid (processid,label)) = newTask ("delete " +++ label) deleteWorkflow`
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
697 698 699
where
	deleteWorkflow` tst=:{hst}
	# (wfls,hst) 		= workflowProcessStore id hst							// read workflow process administration
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
700
	# nwfls				= updateAt (processid - 1) (DeletedWorkflow (-1,label)) wfls	// delete entry in table
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
701
	# (wfls,hst) 		= workflowProcessStore (\_ -> nwfls) hst				// update workflow process administration
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
702 703
	# tst				= deleteSubTasksAndThreads [processid] {tst & hst = hst}		// delete all iTask storage of this process ...
	= (True,{tst & activated = True})								// if everything is fine it should always succeed
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
704

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
705
suspendWorkflow :: !(Wid a) -> Task Bool
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
706
suspendWorkflow (Wid (processid,label)) = newTask ("suspend " +++ label) deleteWorkflow`
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
707 708 709 710 711 712 713 714 715 716 717 718
where
	deleteWorkflow` tst=:{hst}
	# (wfls,hst) 		= workflowProcessStore id hst							// read workflow process administration
	# (ok,nochange,wfl)	= case (wfls!!(processid - 1)) of
							(ActiveWorkflow label entry) -> (True,False,SuspendedWorkflow label entry)
							(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 & hst = hst, activated = True})				// no change needed
	# nwfls				= updateAt (processid - 1) wfl wfls						// update entry
	# (wfls,hst) 		= workflowProcessStore (\_ -> nwfls) hst				// update workflow process administration
	= (ok,{tst & hst = hst, activated = True})									// if everything is fine it should always succeed

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
719
activateWorkflow :: !(Wid a) -> Task Bool
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
720
activateWorkflow (Wid (processid,label)) = newTask ("activate " +++ label) activateWorkflow`
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
721
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
722
	activateWorkflow` tst=:{hst}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
723 724 725 726 727 728 729 730 731
	# (wfls,hst) 		= workflowProcessStore id hst							// read workflow process administration
	# (ok,nochange,wfl)	= case (wfls!!(processid - 1)) of
							(SuspendedWorkflow label entry) -> (True,False,ActiveWorkflow label entry)
							(DeletedWorkflow label) -> (False,True,DeletedWorkflow label) // a deleted workflow cannot be suspendend
							wfl -> (True,True,wfl)								// in case of finsihed or already activated flows
	| nochange			= (ok,{tst & hst = hst, activated = True})				// no change needed
	# nwfls				= updateAt (processid - 1) wfl wfls						// update entry
	# (wfls,hst) 		= workflowProcessStore (\_ -> nwfls) hst				// update workflow process administration
	= (ok,{tst & hst = hst, activated = True})									// if everything is fine it should always succeed
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
732 733

getWorkflowStatus :: !(Wid a) -> Task WorkflowStatus
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
734
getWorkflowStatus (Wid (processid,label)) = newTask ("get status " +++ label) getWorkflowStatus`
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
735 736 737 738 739 740 741 742 743
where
	getWorkflowStatus` tst=:{hst}
	# (wfls,hst) 		= workflowProcessStore id hst							// read workflow process administration
	# status			= case (wfls!!(processid - 1)) of
							(ActiveWorkflow _ _) 		-> WflActive
							(SuspendedWorkflow _ _) 	-> WflSuspended
							(FinishedWorkflow _ _ _) 	-> WflFinished
							(DeletedWorkflow _) 		-> WflDeleted		
	= (status,{tst & hst = hst, activated = True})									// if everything is fine it should always succeed
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
744 745 746

showWorkflows :: !Bool !*HSt -> (![BodyTag],*HSt)
showWorkflows alldone hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
747
# (wfls,hst) 		= workflowProcessStore id hst								// read workflow process administration
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
748 749 750 751
= (mkTable wfls,hst)
where
	mkTable []		= []
	mkTable wfls	=	[showLabel ("Workflow Process Table:"),
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
752 753
						STable []	(   [ [showTrace "Workflow Id:", showTrace "User Id:", showTrace "Task Name:", showTrace "Status:"]
										, [Txt "0" , Txt "0", Txt defaultWorkflowName, if alldone (Txt "Finished") (Txt "Active")] 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
754 755 756 757 758
										: [[Txt (toString i)] ++ showStatus wfl \\ wfl <- wfls & i <- [1..]]
										]
									),
						Hr []
						]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
759 760 761 762
	showStatus (ActiveWorkflow 	 	(userid,label) dyntask)		= [Txt (toString userid), Txt label, Txt "Active"]
	showStatus (SuspendedWorkflow 	(userid,label) dyntask)		= [Txt (toString userid), Txt label, Txt "Suspended"]
	showStatus (FinishedWorkflow 	(userid,label) dyn dyntask)	= [Txt (toString userid), Txt label, Txt "Finished"]
	showStatus (DeletedWorkflow  	(userid,label))				= [Txt (toString userid), Txt label, Txt "Deleted"]