iTasks.icl 117 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
					, workflowLink	:: !WorkflowLink	// process table entry information
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
:: 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
37 38
				|	(+-+) 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
39
				|	DivCode String HtmlTree				// code that should be labeled with a div, used for Ajax and Client technology
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
40 41 42 43
:: Options		=	{ tasklife		:: !Lifespan		// default: Session		
					, taskstorage	:: !StorageFormat	// default: PlainString
					, taskmode		:: !Mode			// default: Edit
					, gc			:: !GarbageCollect	// default: Collect
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
44
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
45
:: StaticInfo	=	{ currentUserId	:: UserId			// id of application user 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
46 47
					, threadTableLoc:: !Lifespan		// where to store the server thread table, default is Session
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
48
:: GarbageCollect =	Collect | NoCollect
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
49
:: Trace		=	Trace !TraceInfo ![Trace]			// traceinfo with possibly subprocess
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
50
:: 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
51

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
52
:: ThreadTable	:== [TaskThread]						// thread table is used for Ajax and OnClient options
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
53
:: TaskThread	=	{ thrTaskNr			:: !TaskNr		// task number to recover
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
54
					, thrUserId			:: !UserId		// which user has to perform the task
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
55
					, thrWorkflowLink	:: !WorkflowLink// what was the name of workflow process it was part off
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
56 57 58
					, 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
59
					, thrKind			:: !ThreadKind 	// kind of thread
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
60
					, thrVersionNr		:: !Int			// version number of application when thread was created
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
61
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
62 63 64
:: 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
65
				|	ExceptionHandler					// Exception handler only works on server
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
66
				|	AnyThread							// Used for garbage collection
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
67
:: GlobalInfo	=	{ versionNr			:: !Int			// latest querie number of a user
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
68 69 70
					, 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
71 72 73
:: UserStartUpOptions
				= 	{ traceOn			:: !Bool			
					, threadStorageLoc	:: !Lifespan		
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
74
					, showUsersOn		:: !Maybe !Int	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
75
					, versionCheckOn	:: !Bool
76
					, headerOff			:: !Maybe HtmlCode
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
77
					, testModeOn		:: !Bool
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
78
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
79
:: Wid a			= Wid WorkflowLink					// id of workflow process
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
80 81 82
:: WorflowProcess 	= ActiveWorkflow 	ProcessIds !(TCl !Dynamic)
					| SuspendedWorkflow ProcessIds !(TCl !Dynamic)
					| FinishedWorkflow 	ProcessIds !Dynamic !(TCl !Dynamic)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
83 84 85 86 87 88 89 90
					| DeletedWorkflow	ProcessIds

:: TaskName			:== !(!UserId,!ProcessNr,!WorkflowLabel,!TaskLabel)	// id of user, workflow process name, task name
:: WorkflowLink		:== !(Entry,ProcessIds)						// entry in table together with unique id which is used for checking whether the reference is still valid
:: ProcessIds		:== !(!UserId,!ProcessNr,!WorkflowLabel)	// user id, process id and name given to a workflow process; is used as unique identifier in process table
:: WorkflowLabel	:== !String
:: Entry			:== !Int
:: ProcessNr		:== !Int
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
91

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
92
// Initial values
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
93

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

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

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
111 112 113
initialOptions ::  !UserId !Lifespan  -> !Options 
initialOptions thisUser location 
				=	{ tasklife 		= if (thisUser >= 0) location Session 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
114 115 116 117
					, taskstorage 	= PlainString
					, taskmode 		= Edit 
					, gc			= Collect
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
118 119

initStaticInfo :: UserId !Lifespan -> StaticInfo
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
120
initStaticInfo thisUser location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
121
=					{ currentUserId	= thisUser 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
122
					, threadTableLoc= location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
123 124
					}

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

135 136 137
// ******************************************************************************************************
// Overloaded Functions on Tasks
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
138

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
139
class 	(<<@) infixl 3 b ::  !(Task a) !b  -> (Task a)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
140
instance <<@  Lifespan
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
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
158 159 160 161 162 163 164
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
165 166
class 	(@>>) infixl 7 b ::  !b !(Task a)   -> (Task a) | iData a
instance @>>  SubPage
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
167 168
where   (@>>) UseAjax task			= \tst -> IF_Ajax 
												(mkTaskThread UseAjax task tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
169
												(newTask "Ajax Thread Disabled" task tst) 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
170 171
		(@>>) OnClient  task 		= \tst -> IF_Ajax 
												(mkTaskThread OnClient task tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
172
												(newTask "Client Thread Disabled" task tst) 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
173

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
174 175 176 177 178
instance == GarbageCollect
where
	(==) Collect   Collect 		= True
	(==) NoCollect NoCollect 	= True
	(==) _ _ 					= False
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
179 180 181 182 183 184 185 186 187
	
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
188

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
189 190 191 192 193 194 195 196
instance == WorkflowStatus
where
	(==) WflActive     			WflActive 	   	= True
	(==) WflSuspended    		WflSuspended 	= True
	(==) WflFinished    		WflFinished 	= True
	(==) WflDeleted 			WflDeleted		= True
	(==) _ 						_ 				= False

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
197 198 199 200 201 202 203 204 205
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
206 207 208 209 210 211 212 213 214
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
215
	determineUserOptions` [NoVersionCheck:xs] 		options = determineUserOptions` xs {options & versionCheckOn = False}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
216
	determineUserOptions` [MyHeader bodytag:xs] 	options = determineUserOptions` xs {options & headerOff = Just bodytag}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
217 218
	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
219

220
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
221
// *** wrappers for the end user, to be used in combination with an iData wrapper...
222
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
223

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
224
singleUserTask :: ![StartUpOptions] !(Task a) !*HSt -> (!Bool,Html,*HSt) | iData a 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
225
singleUserTask startUpOptions maintask hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
226 227
# userOptions			= determineUserOptions [ThreadStorage TxtFile:startUpOptions]
# tst					= initTst 0 Session userOptions.threadStorageLoc hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
228
# (exception,html,hst)	= startTstTask 0 False (False,[]) userOptions maintask tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
229
= mkHtmlExcep "singleUser" exception html hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
230

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
231
multiUserTask :: ![StartUpOptions] !(Task a) !*HSt -> (!Bool,Html,*HSt) | iData a 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
232
multiUserTask startUpOptions maintask  hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
233
# userOptions 			= determineUserOptions [TestModeOff, VersionCheck, ThreadStorage TxtFile:startUpOptions] 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
234 235 236
# nusers				= case userOptions.showUsersOn of
							Nothing -> 0
							Just n	-> n
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
237
| nusers == 0			= singleUserTask startUpOptions maintask  hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
238 239 240
# (idform,hst) 			= FuncMenu (Init,nFormId "User_Selected" 
							(0,[("User " +++ toString i,\_ -> i) \\ i<-[0..nusers - 1] ])) hst
# currentWorker			= snd idform.value
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
241
# tst					= initTst currentWorker TxtFile userOptions.threadStorageLoc hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
242
# (exception,html,hst) 	= startTstTask currentWorker True 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
243
							(if userOptions.traceOn (idform.changed,idform.form) (False,[])) userOptions maintask tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
244
= mkHtmlExcep "multiUser" exception html hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
245

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
246 247
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
248
# userOptions 						= determineUserOptions startUpOptions 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
249
# tst								= initTst -1 Session userOptions.threadStorageLoc hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
250
# (((new,i),a),tst=:{activated,html,hst})	= taska tst									// for doing the login 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
251 252 253 254 255 256
| 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] 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
257
# tst								= initTst i Session userOptions.threadStorageLoc hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
258
# (exception,body,hst) 				= startTstTask i True (False,[]) userOptions (newUserTask ((new,i),a) <<@ TxtFile) tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
259 260 261 262 263 264 265 266 267 268
= 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
269 270 271 272
	newUserTask ((True,i),a) 	= (spawnWorkflow i True (userTask i a)) =>> \_ -> return_V Void
	newUserTask _ 				= return_V Void


Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
273
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
274
// Main routine for the creation of the workflow page
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
275
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
276

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

280
// prologue
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
281

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
282

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
283
| thisUser < 0 			= abort "Users should have id's >= 0 !\n"
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
284
# (refresh,hst) 		= simpleButton refreshId "Refresh" id hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
285 286
# (traceAsked,hst) 		= simpleButton traceId "ShowTrace" (\_ -> True) hst
# doTrace				= traceAsked.value False
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
287
	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
288
# versionsOn			= IF_ClientTasks False versionCheckOn										// no version control on client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
289 290
# 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
291
# (pversion,hst)	 	= setPUserNr thisUser id hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
292 293 294
# (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
295
# iTaskHeader			=	[Table [Tbl_Width (Percent 100)] [Tr [] 
Bas Lijnse's avatar
Bas Lijnse committed
296
							[ Td [] [Img [Img_Src (ThisExe +++ "/img/clean-logo.jpg"),Img_Align Alo_Middle]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
297
									,showHighLight " i -Task", showLabel " Workflow System "]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
298 299
							, Td [Td_Align Aln_Right] (multiuserform ++ refresh.form ++ ifTraceOn traceAsked.form)] ]]++
							[Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
300
| versionconflict	 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
301
	# iTaskInfo			= mkDiv "iTaskInfo" [showLabel "Cannot apply request. Version conflict. Please refresh the page!", Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
302
	= (True,[Ajax 	[ ("thePage",iTaskHeader ++ iTaskInfo)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
303
						]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
304
				],hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
305

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
306
// Here the iTasks are evaluated ...
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
307
													    
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
308
# maintask				= scheduleWorkflows maintask															// schedule all active tasks, not only maintask
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
309
# ((toServer,thrOwner,event,thrinfo,threads),tst=:{html,hst,trace,activated})	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
310
						=  ((IF_Ajax (startAjaxApplication thisUser pversion) startMainTask)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
311
							maintask) {tst & hst = hst, trace = if doTrace (Just []) Nothing, activated = True, html = BT []}
312

313
// epilogue
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
314 315

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

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
319
# showCompletePage		= IF_Ajax (hd threads == [-1]) True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
320
# (threadtrace,tst)	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
321
						= if TraceThreads showThreadTable nilTable {tst & hst = hst} 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
322
# threadsText			= if showCompletePage "" (foldl (+++) "" [showThreadNr tasknrs +++ " + " \\ tasknrs <- reverse threads])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
323
# (processadmin,tst=:{hst})	= showWorkflows activated tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
324
# (threadcode,taskname,mainbuts,subbuts,seltask,hst)	
325
						= Filter showCompletePage thrOwner html hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
326 327

# iTaskInfo				= 	mkDiv "iTaskInfo" 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
328 329 330 331 332
							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
333 334 335
										if (thrinfo == "" ) [] [showLowLight thrinfo, showText " - "] ++
										if (multiuser && versionsOn)
											 [showText "Query " , showTrace ((sversion +++> " / " )<+++ appversion)] [] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
336 337 338 339 340 341 342
										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
343
# iTaskTraceInfo		=	showOptions staticInfo.threadTableLoc ++ processadmin ++ threadtrace ++ [printTrace2 trace ]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
344
| showCompletePage		=	(toServer,[Ajax [("thePage",	iTaskHeader ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
345 346 347
															iTaskInfo  ++
															if (doTrace && traceOn)
																	iTaskTraceInfo
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
348
																	[	leftright taskname subbuts
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
349
																		, mainbuts <=>  seltask
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
350
																	]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
351 352
											)]
									] 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
353
							,hst)
354
# (newthread,oldthreads)=	(hd threads, tl threads)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
355
| otherwise				=	(toServer,[Ajax (	[("iTaskInfo", iTaskInfo)] ++			// header ino
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
356
											[(showTaskNr childthreads,[showText " "]) \\ childthreads <- oldthreads] ++ //clear childthreads, since parent thread don't need to be on this page
357
											[(showTaskNr newthread, if (isNil threadcode) seltask threadcode)]	// task info
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
358 359
										   )
									]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
360
							,hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
361
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
362
//	wrap maintask = scheduleWorkflows (newTask "main" (assignTaskTo False 0 ("main",maintask)))				
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
363 364 365 366
//	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
367

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
368 369 370 371 372
	leftright left right 
	=	Table [Tbl_Width (Percent 100)] 
			[Tr []	[ Td [] left
					, Td [Td_Align Aln_Right] right]
					]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
373

374 375
	nilTable tst = 	([],tst)

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

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
381 382
	mbUpdate True _ = id
	mbUpdate _ f = f
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
383

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
384 385
	ifTraceOn form = if traceOn form []

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
386
	showOptions location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
387 388
	= [showText "Version nr: ", showTrace iTaskVersion] ++
	  [showText " - Enabled: "] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
389 390 391 392
	  [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
393
	  [showText " - Disabled: "] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
394 395 396 397
	  [showTrace (IF_Ajax 	"" " - Ajax " )] ++
	  [showTrace (IF_ClientServer	"" " - Client" )] ++
	  [showTrace (IF_Database "" " - Database" )] ++
	  [showTrace (IF_DataFile "" " - DataFile" )] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
398 399 400
	  [Br,Hr []]


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

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
430
		unzipsubtasks :: ![(!ProcessNr,!WorkflowLabel,!TaskLabel,![BodyTag])] -> (![TaskLabel],![[BodyTag]])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
431
		unzipsubtasks []		= ([],[])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
432
		unzipsubtasks [(pid,wlabel,tlabel,tcode):subtasks]		
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
433 434 435
		# (labels,codes)		= unzipsubtasks subtasks
		= ([tlabel:labels],[tcode:codes])

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
436 437
	Collect :: !UserId !UserId ![(!ProcessNr,!WorkflowLabel,!TaskLabel,![BodyTag])] !HtmlTree -> (![BodyTag],![(!ProcessNr,!WorkflowLabel,!TaskLabel,![BodyTag])])
	Collect thisuser taskuser accu ((nuserid,processnr,workflowLabel,taskname) @@: tree) 	// Collect returns the wanted code, and the remaining code
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
438
	# (myhtml,accu)	= Collect thisuser nuserid accu tree									// Collect all code of this user belonging to this task
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
439 440
	| thisuser == nuserid && not (isNil myhtml)
							= ([],[(processnr,workflowLabel,taskname,myhtml):accu])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
441
	| otherwise				= ([],accu)
442 443 444
	Collect thisuser taskuser accu (nuser -@: tree)
	| thisuser == nuser 	= ([],accu)
	| otherwise				= Collect thisuser taskuser accu tree
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
445 446 447 448 449 450 451 452
	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)
453 454
	Collect thisuser taskuser accu (BT bdtg)
	| thisuser == taskuser	= (bdtg,accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
455
	| otherwise				= ([],accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
456 457
	Collect thisuser taskuser accu (DivCode id tree)
	# (html,accu)			= Collect thisuser taskuser accu tree
458 459
	| thisuser == taskuser 	= (mkDiv id html,accu)
	= ([],accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
460

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

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

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

532 533 534
// ******************************************************************************************************
// Event handling for Ajax calls and Sapl handling on the client
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
535

536 537 538 539 540 541 542
// 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
543

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
544

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

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

600
# (mbthread,tst)		= findParentThread (tl thread.thrTaskNr) tst			// look for thread to evaluate
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
601
= 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
602
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
603 604
	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
605

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

610 611
	# (_,tst=:{activated}) 	= evalTaskThread parent {tst & html = BT []}		// start parent
	| not activated																// parent thread not yet finished
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
612
		# tst				= copyThreadTableToClient tst						// copy thread table to client
613
		= ((False,thisUser,event, "",[parent.thrTaskNr:accu]),tst)				// no further evaluation, aks user for more input
614
	# (mbthread,tst)		= findParentThread (tl parent.thrTaskNr) tst		// look for thread to evaluate
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632
	= 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
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
633
	parseString :: !Expr -> Maybe String
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
634 635 636 637 638 639 640 641
	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)

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
642 643 644 645 646 647 648 649 650 651 652 653 654
isValidWorkflowReference :: !WorflowProcess !ProcessIds -> Bool								// checks whether pointer to workflow is still refering to to right entry in the table
isValidWorkflowReference (ActiveWorkflow 	ids _)		idsref = drop1tuple3 ids == drop1tuple3 idsref
isValidWorkflowReference (SuspendedWorkflow ids _)		idsref = drop1tuple3 ids == drop1tuple3 idsref
isValidWorkflowReference (FinishedWorkflow 	ids _ _)	idsref = drop1tuple3 ids == drop1tuple3 idsref
isValidWorkflowReference (DeletedWorkflow	ids)		idsref = drop1tuple3 ids == drop1tuple3 idsref

drop1tuple3 (x,y,z) = (y,z)

getWorkflowUser :: !WorflowProcess -> UserId						// fetch user who should do the work
getWorkflowUser (ActiveWorkflow 	(userid,_,_) _)		= userid 
getWorkflowUser (SuspendedWorkflow  (userid,_,_) _)		= userid
getWorkflowUser (FinishedWorkflow 	(userid,_,_) _ _)	= userid
getWorkflowUser (DeletedWorkflow	(userid,_,_))		= userid
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
655

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
656 657 658 659 660 661 662 663 664 665 666 667 668 669
setWorkflowUser :: !UserId !WorflowProcess -> WorflowProcess						// fetch user who should do the work
setWorkflowUser nuserid (ActiveWorkflow 		(userid,procnr,wflab) task)		= (ActiveWorkflow 		(nuserid,procnr,wflab) task)
setWorkflowUser nuserid (SuspendedWorkflow  	(userid,procnr,wflab) task)		= (SuspendedWorkflow  	(nuserid,procnr,wflab) task)
setWorkflowUser nuserid (FinishedWorkflow 		(userid,procnr,wflab) dyn task)	= (FinishedWorkflow 	(userid,procnr,wflab) dyn task)
setWorkflowUser nuserid (DeletedWorkflow		(userid,procnr,wflab))			= (DeletedWorkflow		(nuserid,procnr,wflab))

getTask :: !WorflowProcess -> Task Dynamic
getTask (ActiveWorkflow 	(_,_,_) (TCl task))		= task 
getTask (SuspendedWorkflow  (_,_,_) (TCl task))		= task
getTask (FinishedWorkflow 	(_,_,_) _ (TCl task))	= task

isDeletedWorkflow :: !WorflowProcess -> Bool
isDeletedWorkflow (DeletedWorkflow _) = True
isDeletedWorkflow _	= False
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
670

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
671
workflowProcessStore ::  !((!Int,![WorflowProcess]) -> (!Int,![WorflowProcess])) !*TSt -> (!(!Int,![WorflowProcess]),!*TSt) 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
672 673 674 675 676 677 678 679
workflowProcessStore wfs tst	
= 	IF_ClientTasks												
			(abort "Cannot access workflow process table on cleint\n")			// workflow table only on server site
			(workflowProcessStore` wfs tst)										// access workflow store
where
	workflowProcessStore` wfs tst=:{hst}	
	# (form,hst) = mkStoreForm (Init, pFormId workflowProcessStoreName (0,[]) <@ NoForm) wfs hst
	= (form.value,{tst & hst = hst})
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
680

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
681 682
scheduleWorkflows :: !(Task a) -> (Task a) | iData a
scheduleWorkflows maintask = scheduleWorkflows`
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
683
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
684 685 686 687
	scheduleWorkflows` tst 
	# (a,tst=:{activated}) 	= newTask defaultWorkflowName (assignTaskTo False 0 ("main",maintask)) tst	// start maintask
	# ((_,wfls),tst) 		= workflowProcessStore id tst												// read workflow process administration
	# (done,tst)			= scheduleWorkflowTable True wfls 0 {tst & activated = True}				// all added workflows processes are inspected (THIS NEEDS TO BE OPTIMIZED AT SOME STAGE)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
688
	= (a,{tst & activated = activated && done})															// whole application ends when all processes have ended
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
689

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
690 691
scheduleWorkflowTable done [] _ tst = (done,tst)
scheduleWorkflowTable done [ActiveWorkflow _ (TCl dyntask):wfls] procid tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
692
# (_,tst=:{activated}) = dyntask {tst & activated = True}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
693 694 695 696
= scheduleWorkflowTable (done && activated) wfls (inc procid) {tst & activated = activated}
scheduleWorkflowTable done [SuspendedWorkflow _ _:wfls] procid tst
= scheduleWorkflowTable done wfls (inc procid) tst
scheduleWorkflowTable done [FinishedWorkflow _ _ (TCl dyntask):wfls] procid tst	// just to show result in trace..
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
697
//# (_,tst) = dyntask tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
698 699 700
= scheduleWorkflowTable done wfls (inc procid) tst
scheduleWorkflowTable done [DeletedWorkflow _:wfls] procid tst
= scheduleWorkflowTable done wfls (inc procid) tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
701

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
702 703
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
704
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725
	spawnWorkflow` options tst
	# ((processid,wfls),tst) 		
						= workflowProcessStore id tst							// read workflow process administration
	# (found,entry)		= findFreeEntry wfls 1									// found entry in table
	# processid			= processid + 1											// process id currently given by length list, used as offset in list
	# wfl				= mkdyntask options entry processid task 				// convert user task in a dynamic task
	# nwfls				= if found 
							(updateAt (entry - 1) (if active ActiveWorkflow SuspendedWorkflow (userid,processid,label) (TCl wfl)) wfls)
							(wfls ++ [if active ActiveWorkflow SuspendedWorkflow (userid,processid,label) (TCl wfl)])				// turn task into a dynamic task
	# (wfls,tst) 		= workflowProcessStore (\_ -> (processid,nwfls)) tst	// write workflow process administration
	# (_,tst)			= if active wfl (\tst -> (undef,tst)) tst				// if new workflow is active, schedule it in
	= (Wid (entry,(userid,processid,label)),{tst & activated = True})

	findFreeEntry :: [WorflowProcess] Int -> (Bool,Int)
	findFreeEntry [] n	= (False,n)
	findFreeEntry [DeletedWorkflow _:wfls] n = (True,n)
	findFreeEntry [_:wfls] n = findFreeEntry wfls (n + 1)

	mkdyntask options entry processid task 
	=  (\tst -> convertTask entry processid label task 
				{tst & tasknr = [entry - 1],activated = True,userId = userid, options = options,workflowLink = (entry,(userid,processid,label))})
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
726
	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
727
	convertTask entry processid label task tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
728

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
729 730 731
	# ((processid,wfls),tst) 	= workflowProcessStore id tst					// read workflow process administration
	# wfl						= wfls!!(entry - 1)								// fetch entry
	# currentWorker				= getWorkflowUser wfl							// such that worker can be changed dynamically !
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
732 733 734
	# (a,tst=:{activated})		= newTask label (assignTaskTo False currentWorker ("main",task)) tst			

//	# (a,tst=:{activated})		= newTask label (assignTaskTo False userid ("main",task)) tst			
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
735
	# dyn						= dynamic a
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
736 737 738 739
	| not activated				= (dyn,tst)										// not finished, return
	# ((_,wfls),tst) 			= workflowProcessStore id tst					// read workflow process administration
	# wfls						= case (wfls!!(entry - 1)) of					// update process administration
										(ActiveWorkflow _ acttask) -> updateAt (entry - 1) (FinishedWorkflow (currentWorker,processid,label) dyn acttask) wfls
Rinus Plasmeijer's avatar