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 84 85 86 87
:: Wid a			= Wid WorkflowName					// id of workflow process
:: WorflowProcess 	= ActiveWorkflow 	!WorkflowLabel !(TCl Dynamic)
					| SuspendedWorkflow !WorkflowLabel !(TCl Dynamic)
					| FinishedWorkflow 	!WorkflowLabel !Dynamic !(TCl Dynamic)
					| DeletedWorkflow	!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
workFlowTask :: ![StartUpOptions] !(Task (UserId,a)) !((UserId,a) -> Task b) !*HSt -> (!Bool,Html,*HSt) | iData b 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
264
workFlowTask  startUpOptions taska iataskb hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
265 266 267
# userOptions 						= determineUserOptions startUpOptions 
# tst								= initTst -1 userOptions.threadStorageLoc hst
# ((i,a),tst=:{activated,html,hst})	= taska tst									// for doing the login 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
268
| not activated
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
269 270
	# iTaskHeader					= [showHighLight "i-Task", showLabel " - Multi-User Workflow System ",Hr []]
	# iTaskInfo						= mkDiv "iTaskInfo" [showText "Login procedure... ", Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
271
	= mkHtmlExcep "workFlow" True [Ajax [ ("thePage",iTaskHeader ++ iTaskInfo ++ noFilter html) // Login ritual cannot be handled by client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
272
										]] hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
273 274
# tst								= initTst i userOptions.threadStorageLoc hst
# (exception,body,hst) 				= startTstTask i True (False,[]) userOptions (iataskb (i,a)) tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
275
= mkHtmlExcep "workFlow" exception body hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
276
where
277
	noFilter :: HtmlTree -> HtmlCode
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
278 279 280 281
	noFilter (BT body) 			= body
	noFilter (_ @@: html) 		= noFilter html
	noFilter (_ -@: html) 		= noFilter html
	noFilter (htmlL +-+ htmlR) 	= [noFilter htmlL  <=>  noFilter htmlR]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
282 283
	noFilter (htmlL +|+ htmlR) 	= noFilter htmlL <|.|> noFilter htmlR
	noFilter (DivCode str html) = noFilter html
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
284
*/
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
285

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
286
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
287
// Main routine for the creation of the workflow page
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
288
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
289

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
290 291
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
292

293
// prologue
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
294

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

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

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
302
# versionsOn			= IF_ClientTasks False versionCheckOn										// no version control on client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
303 304
# 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
305
# (pversion,hst)	 	= setPUserNr thisUser id hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
306 307 308
# (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
309 310
# 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
311
									,showHighLight " i -Task", showLabel " Workflow System "]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
312 313
							, Td [Td_Align Aln_Right] (multiuserform ++ refresh.form ++ ifTraceOn traceAsked.form)] ]]++
							[Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
314
| versionconflict	 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
315
	# iTaskInfo			= mkDiv "iTaskInfo" [showLabel "Cannot apply request. Version conflict. Please refresh the page!", Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
316
	= (True,[Ajax 	[ ("thePage",iTaskHeader ++ iTaskInfo)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
317
						]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
318
				],hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
319 320


Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
321 322
// Here the iTask starts...
													    
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
323
# ((toServer,thrOwner,event,thrinfo,threads),tst=:{html,hst,trace,activated})	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
324
						= (IF_Ajax (startAjaxApplication thisUser pversion) startMainTask)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
325
							maintask {tst & hst = hst, trace = if doTrace (Just []) Nothing, activated = True, html = BT []}
326

327
// epilogue
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
328 329

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

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
333
# showCompletePage		= IF_Ajax (hd threads == [-1]) True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
334
# (threadtrace,tst=:{hst})	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
335
						= if TraceThreads showThreadTable nilTable {tst & hst = hst} 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
336
# threadsText			= if showCompletePage "" (foldl (+++) "" [showThreadNr tasknrs +++ " + " \\ tasknrs <- reverse threads])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
337
# (processadmin,hst)	= showWorkflows activated hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
338
# (threadcode,taskname,mainbuts,subbuts,seltask,hst)	
339
						= Filter showCompletePage thrOwner html hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
340 341

# iTaskInfo				= 	mkDiv "iTaskInfo" 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
342 343 344 345 346
							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
347 348 349
										if (thrinfo == "" ) [] [showLowLight thrinfo, showText " - "] ++
										if (multiuser && versionsOn)
											 [showText "Query " , showTrace ((sversion +++> " / " )<+++ appversion)] [] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
350 351 352 353 354 355 356
										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
357
# iTaskTraceInfo		=	showOptions staticInfo.threadTableLoc ++ processadmin ++ threadtrace ++ [printTrace2 trace ]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
358
| showCompletePage		=	(toServer,[Ajax [("thePage",	iTaskHeader ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
359 360 361
															iTaskInfo  ++
															if (doTrace && traceOn)
																	iTaskTraceInfo
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
362 363
																	[	[[BodyTag taskname, Br] <||> mainbuts] <=>
																		[BodyTag subbuts,Br,Br, BodyTag seltask]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
364
																	]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
365 366
											)]
									] 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
367
							,hst)
368
# (newthread,oldthreads)=	(hd threads, tl threads)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
369
| otherwise				=	(toServer,[Ajax (	[("iTaskInfo", iTaskInfo)] ++			// header ino
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
370
											[(showTaskNr childthreads,[showText " "]) \\ childthreads <- oldthreads] ++ //clear childthreads, since parent thread don't need to be on this page
371
											[(showTaskNr newthread, if (isNil threadcode) seltask threadcode)]	// task info
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
372 373
										   )
									]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
374
							,hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
375
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
376 377 378 379 380
//	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
381 382


383 384
	nilTable tst = 	([],tst)

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

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
390 391
	mbUpdate True _ = id
	mbUpdate _ f = f
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
392

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
393 394
	ifTraceOn form = if traceOn form []

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
395
	showOptions location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
396 397
	= [showText "Version nr: ", showTrace iTaskVersion] ++
	  [showText " - Enabled: "] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
398 399 400 401
	  [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
402
	  [showText " - Disabled: "] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
403 404 405 406
	  [showTrace (IF_Ajax 	"" " - Ajax " )] ++
	  [showTrace (IF_ClientServer	"" " - Client" )] ++
	  [showTrace (IF_Database "" " - Database" )] ++
	  [showTrace (IF_DataFile "" " - DataFile" )] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
407 408 409
	  [Br,Hr []]


410
	mkSTable2 :: [HtmlCode] -> BodyTag
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
411 412 413 414 415 416
	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
417
	Filter :: !Bool !UserId !HtmlTree !*HSt -> *(![BodyTag],![BodyTag],![BodyTag],![BodyTag],![BodyTag],!*HSt)
418 419
	Filter wholepage thrOwner tree hst
	# startuser			= if wholepage defaultUser thrOwner
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
420 421 422 423 424 425 426 427
	# (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
428
	= (threadcode,[showMainLabel chosenMain, showTrace " / ", showLabel chosenTask],mainButtons,subButtons,tcode!!taskSelected,hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444
	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
445
	| thisuser == ntaskuser && not (isNil myhtml)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
446
							= ([],[(workflowName,taskname,myhtml):accu])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
447
	| otherwise				= ([],accu)
448 449 450
	Collect thisuser taskuser accu (nuser -@: tree)
	| thisuser == nuser 	= ([],accu)
	| otherwise				= Collect thisuser taskuser accu tree
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
451 452 453 454 455 456 457 458
	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)
459 460
	Collect thisuser taskuser accu (BT bdtg)
	| thisuser == taskuser	= (bdtg,accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
461
	| otherwise				= ([],accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
462 463
	Collect thisuser taskuser accu (DivCode id tree)
	# (html,accu)			= Collect thisuser taskuser accu tree
464 465
	| thisuser == taskuser 	= (mkDiv id html,accu)
	= ([],accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
466

467
	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
468 469
	showThreadTable tst=:{staticInfo}
	# thisUser		= staticInfo.currentUserId
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
470
	# (tableS,tst)	= ThreadTableStorage id tst													// read thread table from server
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
471
	# tableS		= sortBy (\e1=:{thrTaskNr = t1} e2=:{thrTaskNr =t2} = t1 < t2) tableS
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
472
	# (tableC,tst)	= IF_ClientServer
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
473
						(\tst -> ClientThreadTableStorage id tst)								// read thread table from client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
474
						(\tst -> ([],tst)) tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
475 476
	
	# tableC		= sortBy (\e1=:{thrTaskNr = t1} e2=:{thrTaskNr =t2} = t1 < t2) tableC
477 478
	# bodyS			= 	if (isNil tableS)
						[]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
479
						[showLabel "Server Thread Table: ",
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
480 481
						STable []	(   [[showTrace "UserNr:", showTrace "Kind:", showTrace "TaskNr:", showTrace "Created:"
										 ,showTrace "Storage"]] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
482 483 484 485 486
										[	[ 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
487 488 489
											] 
											\\ entry <- tableS
										]
490 491
									),
						Hr []
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
492
						]
493 494
	# bodyC			= if (isNil tableC)
						[]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
495
						[showLabel ("Client User " +++ toString thisUser +++ " Thread Table: "),
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
496 497
						STable []	(   [[showTrace "UserNr:", showTrace "Kind:", showTrace "TaskNr:", showTrace "Created:"
										 ,showTrace "Storage"]] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
498 499 500 501 502
										[	[ 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
503 504 505
											] 
											\\ entry <- tableC
										]
506 507
									),
						Hr []
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
508 509
						]
	= (bodyS ++ bodyC,tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
510

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
511 512
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
513 514
# btnsId			= iTaskId userId tasknr (myid <+++ "genBtns")
# myidx				= length btnnames
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
515
//| myidx == 1		= ((0,[],[]),hst)													// no task button if there is only one task to choose from
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
516 517 518 519
# (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
520
= ((chosen,buttons.form,btnnames!!chosen),hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
521
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
522 523 524 525
	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
526
	but i = iTaskButton i
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
527 528 529 530 531 532 533 534 535

	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
536
	# (storeform,hst)	= mkStoreForm (Init,storageFormId info storeId 0) fun hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
537 538
	= (storeform.value,hst)

539 540 541
// ******************************************************************************************************
// Event handling for Ajax calls and Sapl handling on the client
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
542

543 544 545 546 547 548 549
// 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
550

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
551

552
startFromRoot :: !GlobalInfo !TaskNr ![TaskNr] !String !(Task a) !*TSt -> ((!Bool,!Int,TaskNr,!String,![TaskNr]),*TSt)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
553
startFromRoot versioninfo eventnr tasknrs message maintask tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
554 555
=	IF_ClientServer																// we are running client server
		(IF_ClientTasks
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
556
			(stopClient eventnr tasknrs message)								// client cannot evaluate from root of task tree, give it up
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
557
			(evaluateFromRoot versioninfo eventnr tasknrs message maintask) tst	// sever can evaluate from scratch
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
558
		)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
559
	(evaluateFromRoot versioninfo eventnr tasknrs message maintask tst)			// ajax can evaluate from scratch as well
560 561 562 563 564 565
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
566
	evaluateFromRoot versioninfo eventnr tasknrs message maintask tst
567
	# tst					= deleteAllSubTasks versioninfo.deletedThreads tst	// delete subtasks being obsolute
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
568
	# (_,tst) 				= maintask tst										// evaluate main application from scratch
569 570 571 572 573
	# 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
574
startAjaxApplication thisUser versioninfo maintask tst=:{tasknr,options,html,trace,userId}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
575 576 577 578 579 580
# 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
581
						= startFromRoot versioninfo tasknr [tasknr] "No events, page refreshed" maintask tst			
582 583 584
# 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
585
						= startFromRoot versioninfo event [tasknr] "No threads, page refreshed" maintask tst			
586 587
# (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
588
						= startFromRoot versioninfo event [tasknr] "No matching thread, page refreshed" maintask tst			
589 590
# 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
591
	# tst				= copyThreadTableToClient tst							// copy thread table to client
592
	= ((True,defaultUser,event,"Task does not exist anymore, please refresh",[tasknr]), tst)
593
| versioninfo.newThread															// newthread added by someone
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
594
						= startFromRoot versioninfo event [tasknr] "New tasks added, page refreshed" maintask tst			
595
| not (isNil versioninfo.deletedThreads) 										// some thread has been deleted										
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
596
						= startFromRoot versioninfo event [tasknr] "Tasks deleted, page refreshed" maintask tst			
597
| thread.thrUserId <> thisUser													// updating becomes too complicated
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
598
						= startFromRoot versioninfo event [tasknr] ("Thread of user " <+++ thread.thrUserId <+++ ", page refreshed") maintask tst			
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
599 600 601 602 603 604

// 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
605
	= ((False,thisUser,event,"",[thread.thrTaskNr]),tst)						// no further evaluation, aks user for more input
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
606

607
# (mbthread,tst)		= findParentThread (tl thread.thrTaskNr) tst			// look for thread to evaluate
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
608
= 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
609
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
610 611
	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
612

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

617 618
	# (_,tst=:{activated}) 	= evalTaskThread parent {tst & html = BT []}		// start parent
	| not activated																// parent thread not yet finished
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
619
		# tst				= copyThreadTableToClient tst						// copy thread table to client
620
		= ((False,thisUser,event, "",[parent.thrTaskNr:accu]),tst)				// no further evaluation, aks user for more input
621
	# (mbthread,tst)		= findParentThread (tl parent.thrTaskNr) tst		// look for thread to evaluate
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653
	= 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
654 655 656
activateWorkflows :: !(Task a) -> (Task a) | iData a
activateWorkflows maintask = activateWorkflows`
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
657
	activateWorkflows` tst=:{hst} 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
658
	# (a,tst=:{activated,hst}) 	= newTask defaultWorkflowName (assignTaskTo False 0 ("main",maintask)) tst	// start maintask
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
659
	# (wfls,hst) 				= workflowProcessStore id hst					// read workflow process administration
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
660
	# (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
661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678
	= (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
679 680
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
681 682 683 684 685
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
686
	# nwfls				= wfls ++ [if active ActiveWorkflow SuspendedWorkflow label wfl]					// turn task into a dynamic task
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
687
	# (wfls,hst) 		= workflowProcessStore (\_ -> nwfls) hst				// write workflow process administration
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
688
	= (Wid (processid,label),{tst & hst = hst, activated = True})
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
689

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
690 691
	mkdyntask options processid task = TCl (\tst -> convertTask processid label task 
										{tst & tasknr = [processid - 1],activated = True,options = options,workflowName = (processid,label)})
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
692 693
	
	convertTask processid label task tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
694
	# (a,tst=:{hst,activated})		= newTask label (assignTaskTo False userid ("main",task)) tst//newTask label task tst			
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
695 696 697 698 699 700 701 702 703
	# 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
											(ActiveWorkflow _ entry) -> updateAt (processid - 1) (FinishedWorkflow label dyn entry) wfls
											_ -> wfls
	# (wfls,hst) 					= workflowProcessStore (\_ -> wfls) hst		// write workflow process administration
	= (dyn,{tst & hst = hst})												

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
704
waitForWorkflow :: !(Wid a) -> Task a | iData a
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
705
waitForWorkflow (Wid (processid,label)) = newTask ("waiting for " +++ label) waitForResult`
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
706
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
707 708 709 710 711 712 713
	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
714
deleteWorkflow :: !(Wid a) -> Task Bool 
Rinus Plasmeijer's avatar