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

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

// 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

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

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
21 22 23
:: *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
24
					, staticInfo	:: !StaticInfo		// info which does not change during a run
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
25 26 27 28
					, 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
29
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
30
:: UserId		:== !Int
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
31
:: TaskNr		:== [Int]								// task nr i.j is adminstrated as [j,i]
32
:: HtmlTree		=	BT HtmlCode						// simple code
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
33 34 35 36
				|	(@@:) infix  0 (Int,String) HtmlTree// code with id of user attached to it
				|	(-@:) infix  0 Int 			HtmlTree// skip code with this id if it is the id of the user 
				|	(+-+) 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
37
				|	DivCode String HtmlTree				// code that should be labeled with a div, used for Ajax and Client technology
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
38 39 40 41
:: Options		=	{ tasklife		:: !Lifespan		// default: Session		
					, taskstorage	:: !StorageFormat	// default: PlainString
					, taskmode		:: !Mode			// default: Edit
					, gc			:: !GarbageCollect	// default: Collect
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
42
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
43
:: StaticInfo	=	{ currentUserId	:: UserId			// id of application user 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
44 45
					, threadTableLoc:: !Lifespan		// where to store the server thread table, default is Session
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
46

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
47 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,!(!Int,!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 56 57
					, 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
58
					, thrKind			:: !ThreadKind 	// kind of thread
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
59
					, thrVersionNr		:: !Int			// version number of application when thread was created
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
60
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
61 62 63
:: 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
64
				|	ExceptionHandler					// Exception handler only works on server
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
65
				|	AnyThread							// Used for garbage collection
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
66
:: GlobalInfo	=	{ versionNr			:: !Int			// latest querie number of a user
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
67 68 69
					, 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
70 71 72 73 74
:: UserStartUpOptions
				= 	{ traceOn			:: !Bool			
					, threadStorageLoc	:: !Lifespan		
					, showUsersOn		:: !Maybe Int	
					, versionCheckOn	:: !Bool
75
					, headerOff			:: !Maybe HtmlCode
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
76
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
77

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
78
// Initial values
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
79

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
80
initTst :: UserId !Lifespan !*HSt -> *TSt
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
81
initTst thisUser location hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
82 83
				=	{ tasknr		= [-1]
					, activated 	= True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
84
					, staticInfo	= initStaticInfo thisUser location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
85 86 87 88 89 90
					, userId		= if (thisUser >= 0) defaultUser thisUser
					, html 			= BT []
					, trace			= Nothing
					, hst 			= hst
					, options 		= initialOptions
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
91

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
92
initialOptions :: Options
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
93 94 95 96 97
initialOptions	=	{ tasklife 		= Session
					, taskstorage 	= PlainString
					, taskmode 		= Edit 
					, gc			= Collect
					}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
98 99

initStaticInfo :: UserId !Lifespan -> StaticInfo
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
100
initStaticInfo thisUser location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
101
=					{ currentUserId	= thisUser 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
102
					, threadTableLoc= location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
103 104
					}

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
105 106 107 108 109 110 111 112 113
defaultStartUpOptions :: UserStartUpOptions
defaultStartUpOptions
= 	{ traceOn			= True		
	, threadStorageLoc	= IF_ClientServer Session TxtFile		// KLOPT DIT WEL ????		
	, showUsersOn		= Just 5	
	, versionCheckOn	= False
	, headerOff			= Nothing
	}

114 115 116
// ******************************************************************************************************
// Overloaded Functions on Tasks
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
117

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
118
class 	(<<@) infixl 3 b ::  !(Task a) !b  -> (Task a)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
119
instance <<@  Lifespan
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136
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
137 138 139 140 141 142 143
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
144 145
class 	(@>>) infixl 7 b ::  !b !(Task a)   -> (Task a) | iData a
instance @>>  SubPage
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
146 147
where   (@>>) UseAjax task			= \tst -> IF_Ajax 
												(mkTaskThread UseAjax task tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
148
												(newTask "Ajax Thread Disabled" task tst) 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
149 150
		(@>>) OnClient  task 		= \tst -> IF_Ajax 
												(mkTaskThread OnClient task tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
151
												(newTask "Client Thread Disabled" task tst) 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
152

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
153 154 155 156 157
instance == GarbageCollect
where
	(==) Collect   Collect 		= True
	(==) NoCollect NoCollect 	= True
	(==) _ _ 					= False
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
158 159 160 161 162 163 164 165 166
	
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
167

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
168 169 170 171 172 173 174 175 176
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
177 178 179 180 181 182 183 184 185 186 187 188 189

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}
	determineUserOptions` [VersionNoCheck:xs] 		options = determineUserOptions` xs {options & versionCheckOn = False}
	determineUserOptions` [MyHeader bodytag:xs] 	options = determineUserOptions` xs {options & headerOff = Just bodytag}

190
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
191
// *** wrappers for the end user, to be used in combination with an iData wrapper...
192
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
193

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
194
singleUserTask :: ![StartUpOptions] !(Task a) !*HSt -> (!Bool,Html,*HSt) | iCreate a 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
195
singleUserTask startUpOptions task hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
196 197 198
# userOptions			= determineUserOptions startUpOptions
# tst					= initTst 0 userOptions.threadStorageLoc hst
# (exception,html,hst)	= startTstTask 0 False (False,[]) userOptions task tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
199
= mkHtmlExcep "singleUser" exception html hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
200

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
201
multiUserTask :: ![StartUpOptions] !(Task a) !*HSt -> (!Bool,Html,*HSt) | iCreate a 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
202
multiUserTask startUpOptions task  hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
203 204 205 206 207 208 209 210 211 212 213
# userOptions 			= determineUserOptions [VersionCheck, ThreadStorage TxtFile:startUpOptions] 
# nusers				= case userOptions.showUsersOn of
							Nothing -> 0
							Just n	-> n
| nusers == 0			= singleUserTask startUpOptions task  hst 
# (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 
							(if userOptions.traceOn (idform.changed,idform.form) (False,[])) userOptions task tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
214
= mkHtmlExcep "multiUser" exception html hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
215

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
216
workFlowTask :: ![StartUpOptions] !(Task (Int,a)) !((Int,a) -> Task b) !*HSt -> (!Bool,Html,*HSt) | iCreate a 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
217
workFlowTask  startUpOptions taska iataskb hst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
218 219 220
# 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
221
| not activated
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
222 223
	# iTaskHeader					= [BCTxt Aqua "i-Task", CTxt Yellow " - Multi-User Workflow System ",Hr []]
	# iTaskInfo						= mkDiv "iTaskInfo" [Txt "Login procedure... ", Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
224
	= mkHtmlExcep "workFlow" True [Ajax [ ("thePage",iTaskHeader ++ iTaskInfo ++ noFilter html) // Login ritual cannot be handled by client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
225
						]] hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
226 227
# 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
228
= mkHtmlExcep "workFlow" exception body hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
229
where
230
	noFilter :: HtmlTree -> HtmlCode
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
231 232 233 234
	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
235 236
	noFilter (htmlL +|+ htmlR) 	= noFilter htmlL <|.|> noFilter htmlR
	noFilter (DivCode str html) = noFilter html
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
237

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
238 239


Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
240
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
241
// Main routine for the creation of the workflow page
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
242
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
243

244
startTstTask :: !Int !Bool  !(!Bool,!HtmlCode) UserStartUpOptions !(Task a) !*TSt -> (!Bool,!HtmlCode,!*HSt) //| iCreate a 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
245
startTstTask thisUser multiuser (userchanged,multiuserform) {traceOn, threadStorageLoc, showUsersOn, versionCheckOn, headerOff} taska tst=:{hst,tasknr,staticInfo}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
246

247
// prologue
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
248

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

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
254
# versionsOn			= IF_ClientTasks False versionCheckOn											// no version control on client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
255 256
# 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
257
# (pversion,hst)	 	= setPUserNr thisUser id hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
258 259 260
# (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
261 262 263 264 265
# iTaskHeader			=	[Table [Tbl_Width (Percent 100)] [Tr [] 
							[ Td [] [Img [Img_Src (ThisExe +++ "/scleanlogo.jpg"),Img_Align Alo_Middle]
									,BCTxt Aqua "i -Task", CTxt Yellow " Workflow System "]
							, Td [Td_Align Aln_Right] (multiuserform ++ refresh.form ++ ifTraceOn traceAsked.form)] ]]++
							[Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
266
| versionconflict	 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
267
	# iTaskInfo			= mkDiv "iTaskInfo" [CTxt Yellow "Cannot apply request. Version conflict. Please refresh the page!", Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
268
	= (True,[Ajax 	[ ("thePage",iTaskHeader ++ iTaskInfo)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
269
						]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
270
				],hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
271 272


Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
273 274
// Here the iTask starts...
													    
275
# ((toServer,thrOwner,event,thrinfo,threads),tst=:{html,hst,trace})	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
276
						= (IF_Ajax (startAjaxApplication thisUser pversion) startMainTask)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
277
							taska {tst & hst = hst, trace = if doTrace (Just []) Nothing, activated = True, html = BT []}
278

279
// epilogue
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
280 281 282 283

# newUserVersionNr		= 1 + if (pversion.versionNr > sversion) pversion.versionNr sversion					// increment user querie version number
# (_,hst)				= clearIncPUser thisUser (\_ -> newUserVersionNr) hst			// store in session
# (sversion,hst)	 	= setSVersionNr thisUser (\_ -> newUserVersionNr) hst									// store in persistent memory
284

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
285
# showCompletePage		= IF_Ajax (hd threads == [-1]) True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
286
# (threadtrace,tst=:{hst})	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
287 288
//						= IF_Ajax (if TraceThreads showThreadTable nilTable {tst & hst = hst}) ([],{tst & hst = hst})
						= if TraceThreads showThreadTable nilTable {tst & hst = hst} 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
289
# threadsText			= if showCompletePage "" (foldl (+++) "" [showThreadNr tasknrs +++ " + " \\ tasknrs <- reverse threads])
290 291
# (threadcode,selbuts,selname,seltask,hst)	
						= Filter showCompletePage thrOwner html hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
292 293

# iTaskInfo				= 	mkDiv "iTaskInfo" 
294
							(	IF_Ajax (IF_ClientServer (IF_ClientTasks [CTxt Yellow "Client: "] [CTxt Yellow "Server: "]) []) [] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
295
								if multiuser 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
296 297 298 299
									[CTxt White "User: " , CTxt Yellow thisUser, Txt " - "] [] ++
								[CTxt Aqua thrinfo, Txt " - "] ++
								if multiuser
									 [Txt "#User Queries: " , CTxt Silver sversion, Txt " - "] [] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
300
								if versionsOn [Txt "#Server Queries: ", CTxt Silver appversion] [Txt "#Server Queries: - "] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
301
								IF_Ajax
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
302 303 304 305
									( [Txt " - Task#: ", CTxt Silver (showTaskNr  event)] ++
									  if (isNil threads || showCompletePage) [] [Txt " - Thread(s)#: ", CTxt Silver threadsText]
									 ) [] ++
								[Br,Hr []]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
306
							)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
307
# iTaskTraceInfo		=	showOptions staticInfo.threadTableLoc ++ threadtrace ++ [printTrace2 trace ]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
308
| showCompletePage		=	(toServer,[Ajax [("thePage",	iTaskHeader ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
309 310 311 312 313 314
															iTaskInfo  ++
															if (doTrace && traceOn)
																	iTaskTraceInfo
																	[ STable []	[ [BodyTag  selbuts, selname <||>  seltask ]
																				]
																	]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
315 316
											)]
									] 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
317
							,hst)
318
# (newthread,oldthreads)=	(hd threads, tl threads)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
319
| otherwise				=	(toServer,[Ajax (	[("iTaskInfo", iTaskInfo)] ++			// header ino
320 321
											[(showTaskNr childthreads,[Txt " "]) \\ childthreads <- oldthreads] ++ //clear childthreads, since parent thread don't need to be on this page
											[(showTaskNr newthread, if (isNil threadcode) seltask threadcode)]	// task info
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
322 323
										   )
									]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
324
							,hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
325
where
326 327
	nilTable tst = 	([],tst)

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

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
333 334
	mbUpdate True _ = id
	mbUpdate _ f = f
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
335

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
336 337
	ifTraceOn form = if traceOn form []

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
338
	showOptions location
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
339
	= [Txt "Version nr: ", CTxt Silver iTaskVersion] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
340
	  [Txt " - Enabled: "] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
341
	  [CTxt Silver (IF_Ajax 	(" + Ajax (" <+++ location <+++ ") ") "")] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
342
	  [CTxt Silver (IF_ClientServer	(IF_Ajax " + Client" "") "")] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
343
	  [CTxt Silver (IF_Database " + Database" "")] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
344 345
	  [CTxt Silver (IF_DataFile " + DataFile" "")] ++
	  [Txt " - Disabled: "] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
346
	  [CTxt Silver (IF_Ajax 	"" " - Ajax " )] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
347
	  [CTxt Silver (IF_ClientServer	"" " - Client" )] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
348 349
	  [CTxt Silver (IF_Database "" " - Database" )] ++
	  [CTxt Silver (IF_DataFile "" " - DataFile" )] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
350 351 352
	  [Br,Hr []]


353
	mkSTable2 :: [HtmlCode] -> BodyTag
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
354 355 356 357 358 359
	mkSTable2 table
	= Table []	(mktable table)
	where
		mktable table 	= [Tr [] (mkrow rows) \\ rows <- table]	
		mkrow rows 		= [Td [Td_VAlign Alo_Top] [row] \\ row <- rows] 

360 361 362 363 364 365 366 367 368 369 370 371 372
	Filter wholepage thrOwner tree hst
	# startuser			= if wholepage defaultUser thrOwner
	# (threadcode,accu) = Collect thisUser startuser [] ((startuser,"Main") @@: tree) 
	| isNil accu		= (threadcode,[],[],[],hst)
	# (names,tasks) 	= unzip accu
	# info				= initialOptions
	# ((selected,buttons,chosenname),hst) = mkTaskButtons "Main Tasks:" ("User " <+++ thisUser) thisUser [] info names hst 
	= (threadcode,buttons,chosenname,tasks!!if (selected > length accu) 0 selected,hst)

	Collect thisuser taskuser accu ((ntaskuser,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
	| thisuser == ntaskuser && not (isNil myhtml)
							= ([],[(taskname,myhtml):accu])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
373
	| otherwise				= ([],accu)
374 375 376
	Collect thisuser taskuser accu (nuser -@: tree)
	| thisuser == nuser 	= ([],accu)
	| otherwise				= Collect thisuser taskuser accu tree
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
377 378 379 380 381 382 383 384
	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)
385 386
	Collect thisuser taskuser accu (BT bdtg)
	| thisuser == taskuser	= (bdtg,accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
387
	| otherwise				= ([],accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
388 389
	Collect thisuser taskuser accu (DivCode id tree)
	# (html,accu)			= Collect thisuser taskuser accu tree
390 391
	| thisuser == taskuser 	= (mkDiv id html,accu)
	= ([],accu)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
392

393
	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
394 395 396
	showThreadTable tst=:{staticInfo}
	# thisUser		= staticInfo.currentUserId
	# (tableS,tst)	= ThreadTableStorage id tst																// read thread table from server
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
397 398
	# (tableC,tst)	= IF_ClientServer
						(\tst -> ClientThreadTableStorage id tst)											// read thread table from client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
399
						(\tst -> ([],tst)) tst
400 401 402
	# bodyS			= 	if (isNil tableS)
						[]
						[CTxt Yellow "Server Thread Table: ",
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
403 404
						STable []	(   [[CTxt White "UserNr:", CTxt White "Kind:", CTxt White "TaskNr:", CTxt White "Created:"
										 ,CTxt White "Storage"]] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
405 406 407 408
										[	[ Txt (toString entry.thrUserId)
											, Txt (toString entry.thrKind)
											, Txt (showThreadNr entry.thrTaskNr)
											, Txt (toString entry.thrVersionNr)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
409
											, Txt (toString entry.thrOptions.tasklife)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
410 411 412
											] 
											\\ entry <- tableS
										]
413 414
									),
						Hr []
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
415
						]
416 417 418
	# bodyC			= if (isNil tableC)
						[]
						[CTxt Yellow ("Client User " +++ toString thisUser +++ " Thread Table: "),
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
419 420
						STable []	(   [[CTxt White "UserNr:", CTxt White "Kind:", CTxt White "TaskNr:", CTxt White "Created:"
										 ,CTxt White "Storage"]] ++
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
421 422 423 424
										[	[ Txt (toString entry.thrUserId)
											, Txt (toString entry.thrKind)
											, Txt (showThreadNr entry.thrTaskNr)
											, Txt (toString entry.thrVersionNr)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
425
											, Txt (toString entry.thrOptions.tasklife)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
426 427 428
											] 
											\\ entry <- tableC
										]
429 430
									),
						Hr []
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
431 432
						]
	= (bodyS ++ bodyC,tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
433

434
mkTaskButtons :: !String !String !Int !TaskNr !Options ![String] *HSt -> ((Int,HtmlCode,HtmlCode),*HSt)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
435 436 437 438 439 440 441
mkTaskButtons header myid userId tasknr info btnnames hst
# btnsId			= iTaskId userId tasknr (myid <+++ "genBtns")
# myidx				= length btnnames
# (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
442
= ((chosen,[CTxt Red header, Br: buttons.form],[CTxt Yellow (btnnames!!chosen),Br,Br]),hst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
443
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
444 445
	SelectButtons init id info (idx,btnnames) hst = TableFuncBut2 (init,pageFormId info id 
															[[(mode idx n, but txt,\_ -> n)] \\ txt <- btnnames & n <- [0..]]) hst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
446
	but i = iTaskButton i
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
447 448 449 450 451 452 453 454 455

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

459 460 461
// ******************************************************************************************************
// Event handling for Ajax calls and Sapl handling on the client
// ******************************************************************************************************
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
462

463 464 465 466 467 468 469
// 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
470

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
471

472 473
startFromRoot :: !GlobalInfo !TaskNr ![TaskNr] !String !(Task a) !*TSt -> ((!Bool,!Int,TaskNr,!String,![TaskNr]),*TSt)
startFromRoot versioninfo eventnr tasknrs message taska tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
474 475
=	IF_ClientServer																// we are running client server
		(IF_ClientTasks
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
476
			(stopClient eventnr tasknrs message)								// client cannot evaluate from root of task tree, give it up
477
			(evaluateFromRoot versioninfo eventnr tasknrs message taska) tst	// sever can evaluate from scratch
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
478
		)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
479
	(evaluateFromRoot versioninfo eventnr tasknrs message taska tst)						// ajax can evaluate from scratch as well
480 481 482 483 484 485 486 487 488 489 490 491 492 493
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)
	evaluateFromRoot versioninfo eventnr tasknrs message taska tst
	# tst					= deleteAllSubTasks versioninfo.deletedThreads tst	// delete subtasks being obsolute
	# (_,tst) 				= taska tst											// evaluate main application from scratch
	# 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..
494
startAjaxApplication thisUser versioninfo taska tst=:{tasknr,options,html,trace,userId}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
495

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
496 497 498 499 500 501
# 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
502
						= startFromRoot versioninfo tasknr [tasknr] "No events, page refreshed" taska tst			
503 504 505
# event					= fromJust mbevent										// event found
# (table,tst)			= ThreadTableStorage id tst								// read thread table
| isNil table																	// events, but no threads, evaluate main application from scratch
506
						= startFromRoot versioninfo event [tasknr] "No threads, page refreshed" taska tst			
507 508
# (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
509
						= startFromRoot versioninfo event [tasknr] "No matching thread, page refreshed" taska tst			
510 511
# 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
512
	# tst				= copyThreadTableToClient tst							// copy thread table to client
513
	= ((True,defaultUser,event,"Task does not exist anymore, please refresh",[tasknr]), tst)
514
| versioninfo.newThread															// newthread added by someone
515
						= startFromRoot versioninfo event [tasknr] "New tasks added, page refreshed" taska tst			
516
| not (isNil versioninfo.deletedThreads) 										// some thread has been deleted										
517
						= startFromRoot versioninfo event [tasknr] "Tasks deleted, page refreshed" taska tst			
518
| thread.thrUserId <> thisUser													// updating becomes too complicated
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
519
						= startFromRoot versioninfo event [tasknr] ("Thread of user " <+++ thread.thrUserId <+++ ", page refreshed") taska tst			
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
520 521 522 523 524 525

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

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

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

538 539
	# (_,tst=:{activated}) 	= evalTaskThread parent {tst & html = BT []}		// start parent
	| not activated																// parent thread not yet finished
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
540
		# tst				= copyThreadTableToClient tst						// copy thread table to client
541
		= ((False,thisUser,event, "",[parent.thrTaskNr:accu]),tst)				// no further evaluation, aks user for more input
542 543
	# (mbthread,tst)		= findParentThread (tl parent.thrTaskNr) tst		// look for thread to evaluate
	= doParent mbthread taska event [parent.thrTaskNr:accu] {tst & options = options}// continue with grand parent ...
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
544

545 546 547 548 549

// ******************************************************************************************************
// Thread Creation and Deletion
// ******************************************************************************************************

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
550
mkTaskThread :: !SubPage !(Task a) -> Task a 	| iData a										
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
551
// wil only be called with IF_Ajax enabled
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
552 553 554
mkTaskThread UseAjax taska 
= IF_Ajax 																		// create an thread only if Ajax is enabled
	(IF_ClientServer															// we running both client and server
555
		(IF_ClientTasks												
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
556
			(abort "Cannot make Server thread on Client\n")						// cannot create server thread on client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
557
			(newTask "Server Thread" (mkTaskThread2 ServerThread taska))		// create client thread, but executed on server
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
558
		)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
559
		(newTask "Ajax Thread" (mkTaskThread2 ServerThread taska))				// create a server thread, no clients
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
560 561 562 563 564
	)
	taska 																		// no threads made at all
mkTaskThread OnClient taska 
= IF_Ajax 																		// create threads only if Ajax is enabled
	(IF_ClientServer															// we running both client and server
565
		(IF_ClientTasks												
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
566 567
			(newTask "Client Thread" (mkTaskThread2 ClientThread  taska))		// create and execute client thread on client
			(newTask "Client Thread" (mkTaskThread2 ClientServerThread taska)) 	// create client thread, but executed on server
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
568 569 570 571 572 573 574
		)
		(newTask "Ajax Thread (no Client)" (mkTaskThread2 ServerThread taska))	// create a server thread, no clients
	)
	taska 																		// no threads made at all

mkTaskThread2 :: !ThreadKind !(Task a) -> Task a 								// execute a thread
mkTaskThread2 threadkind task = evalTask																
575
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
576
	evalTask tst=:{tasknr,activated,options,userId,staticInfo}					// thread - task is not yet finished
577
	# (mbthread,tst)	= findThreadInTable threadkind tasknr tst				// look if there is an entry for this task
578
	| isNothing mbthread														// not yet, insert new entry		
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
579
		# options 			= {options & tasklife = case threadkind of
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
580 581 582 583 584 585
													ServerThread 		= options.tasklife // staticInfo.threadTableLoc
													ClientServerThread 	= Client
													ClientThread 		= Client
													ExceptionHandler 	= options.tasklife  // staticInfo.threadTableLoc
													else 				= abort "Storing unexpected thread kind"}
		# (versionNr,tst)	= getCurrentAppVersionNr tst						// get current version number of the application
586 587 588
		# tst = insertNewThread 	{ thrTaskNr 		= tasknr
									, thrUserId 		= userId
									, thrOptions 		= options
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
589
									, thrCallback 		= serializeThread task	
590
									, thrCallbackClient = serializeThreadClient task 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
591
									, thrKind			= threadkind
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
592
									, thrVersionNr		= versionNr
593
									} tst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
594
		= evalTask tst															// try it again, entry point should now be there
595
	# (_,thread)		= fromJust mbthread										// entry point found
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
596 597 598 599
	# tst				= if (options.tasklife == Client && 					// if iTasks for this thread are stored on client
								(thread.thrOptions.tasklife <> Client ||		// but new thread is not to be stored on client 
								 staticInfo.currentUserId <> userId))			// or new thread is for someone else
							forceEvalutionOnServer id tst						// storing on client is no longer possible
600 601
	= evalTaskThread thread tst													// and evaluate it

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633
forceEvalutionOnServer tst
=	IF_ClientServer																// we running both client and server
		(IF_ClientTasks												
			id																	// on client we cannot do anything
			forceEvalutionOnServer`												// force evaluation on server
			tst
		)
	tst
where
	forceEvalutionOnServer` tst=:{userId,tasknr} 
	# (mbparent,tst=:{hst})	= findNoClientParentThread tasknr tst
	| isNothing mbparent = {tst & hst = hst}									// cannot find parent, we should abort ????
	# parent 	= fromJust mbparent												// parent thread found which lifespan should be modified 
	# hst		= changeLifespanIData (iTaskId userId (tl parent.thrTaskNr) "") Client parent.thrOptions.tasklife hst
	# tst 		= changeLifespanThreadTable parent.thrTaskNr parent.thrOptions.tasklife {tst & hst = hst}
	= tst

	findNoClientParentThread tasknr tst
	# (mbparent,tst) 	= findParentThread tasknr tst
	| isNil mbparent 	= (Nothing,tst)
	# parent 			= hd mbparent										// thread found
	| parent.thrOptions.tasklife == Client = findNoClientParentThread (tl parent.thrTaskNr) tst
	= (Just parent,tst)

	changeLifespanThreadTable :: !TaskNr !Lifespan *TSt -> *TSt						// change lifespan of of indicated thread in threadtable
	changeLifespanThreadTable tasknr lifespan tst
	# (table,tst)	= ThreadTableStorage id tst										// read thread table on server
	# revtasknr		= reverse (tl tasknr)									
	# ntable 		= [{thread & thrOptions.tasklife = if (isChild revtasknr thread.thrTaskNr) lifespan thread.thrOptions.tasklife} \\ thread <- table]
	# (_,tst)		= ThreadTableStorage (\_ -> ntable) tst							// store thread table
	= tst

634
evalTaskThread :: !TaskThread -> Task a 										// execute the thread !!!!
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
635
evalTaskThread entry=:{thrTaskNr,thrUserId,thrOptions,thrCallback,thrCallbackClient,thrKind} = evalTaskThread` 
636
where
637 638 639 640 641
	evalTaskThread` tst=:{tasknr,options,userId,staticInfo,html}									
	# newThrOptions					= if (thrOptions.tasklife == Client && thrUserId <> staticInfo.currentUserId) 
											{thrOptions & tasklife = Temp}		// the information is not intended for this client, so dot store
											thrOptions
			
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
642
	# (a,tst=:{activated,html=nhtml}) 	
643
		= IF_ClientTasks	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
644 645 646 647 648 649 650 651 652 653 654 655
			(case thrKind of		// we are running on Client, assume that IF_ClientServer and IF_Ajax is set
				 ClientThread 		= deserializeThreadClient thrCallbackClient
				 ClientServerThread	= deserializeThreadClient thrCallbackClient
				 ServerThread 		= abort "Cannot evaluate Server thread on Client\n"
				 else 				= abort "Thread administration error in evalTaskThread"
			)
			(case thrKind of		// we are running on the Server
				 ClientThread 		= abort "Cannot evaluate Client thread on Server\n"
				 ClientServerThread	= deserializeThread thrCallback
				 ServerThread 		= deserializeThread thrCallback
				 else 				= abort "Thread administration error in evalTaskThread"
			)
656
			{tst & tasknr = thrTaskNr, options = newThrOptions, userId = thrUserId,html = BT []} 
657 658 659 660 661 662 663 664 665 666
	| activated																	// thread is finished, delete the entry...
		# tst =  deleteThreads thrTaskNr {tst & html = html +|+ nhtml}			// remove thread from administration
		= (a,{tst & tasknr = tasknr, options = options, userId = userId})		// remove entry from table
	= (a,{tst & tasknr = tasknr, options = options, userId = userId,html = html +|+ DivCode (showTaskNr thrTaskNr) nhtml})

	
// ******************************************************************************************************
// Thread Table Storage Manipulation functions
// ******************************************************************************************************

667
// TO DO : Currently an unordered list is used, should become an ordered tree someday...
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
668
// TO DO: Put this stuf in another module
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
669 670 671 672

ThreadTableStorage :: !(ThreadTable -> ThreadTable) -> (Task ThreadTable)		// used to store Tasknr of callbackfunctions / threads
ThreadTableStorage fun = handleTable
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
673
	handleTable tst 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
674 675 676
	= IF_Ajax 																	// threads only used when Ajax is enabled
		(IF_ClientServer														// we running both client and server
			(IF_ClientTasks												
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
677 678 679
				ClientThreadTableStorage										// thread table on client
				ServerThreadTableStorage										// threadtable on server
				fun tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
680
			)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
681
			(ServerThreadTableStorage fun tst)									// thread table on server when ajax used
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
682
		)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
683 684
		(ServerThreadTableStorage fun tst)										// thread table used for exception handling only ???
//		(abort "Thread table storage only used when Ajax enabled")				// no threads made at all
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
685

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
686 687 688 689 690 691 692
ServerThreadTableStorage:: !(ThreadTable -> ThreadTable) -> (Task ThreadTable)	// used to store Tasknr of callbackfunctions / threads
ServerThreadTableStorage fun = handleTable
where
	handleTable tst=:{staticInfo} = ThreadTableStorageGen serverThreadTableId staticInfo.threadTableLoc fun tst 

	serverThreadTableId 		= "Application" +++  "-ThreadTable"

693
ClientThreadTableStorage:: !(ThreadTable -> ThreadTable) -> (Task ThreadTable)	// used to store Tasknr of callbackfunctions / threads
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
694 695 696 697 698
ClientThreadTableStorage fun = handleTable
where
	handleTable tst=:{staticInfo} = ThreadTableStorageGen (clientThreadTableId staticInfo.currentUserId) Client fun tst 

	clientThreadTableId userid	= "User" <+++ userid  <+++ "-ThreadTable"
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
699 700 701 702

ThreadTableStorageGen :: !String !Lifespan !(ThreadTable -> ThreadTable) -> (Task ThreadTable)		// used to store Tasknr of callbackfunctions / threads
ThreadTableStorageGen tableid lifespan fun = handleTable						// to handle the table on server as well as on client
where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
703
	handleTable tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
704 705 706 707
	# (table,tst) = LiftHst (mkStoreForm (Init,storageFormId 
						{ tasklife 		= lifespan
						, taskstorage 	= PlainString 
						, taskmode		= NoForm
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
708
						, gc			= Collect} tableid []) fun) tst
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
709 710 711 712 713
	= (table.value,tst)

copyThreadTableToClient ::  !*TSt -> !*TSt										// copies all threads for this user from server to client thread table
copyThreadTableToClient tst
=	IF_ClientServer										
714
		(IF_ClientTasks id copyThreadTableToClient` tst)						// only if we are on the server the copied can be made
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
715 716 717
		tst

copyThreadTableToClient` :: !*TSt -> !*TSt										// copies all threads for this user from server to client thread table
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
718
copyThreadTableToClient` tst
719 720
# ((mythreads,_),tst)	= splitServerThreadsByUser tst							// get thread table on server
# (clientThreads,tst)	= ClientThreadTableStorage (\_ -> mythreads) tst		// and store in client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
721 722
= tst

723
splitServerThreadsByUser :: !*TSt -> !(!(!ThreadTable,!ThreadTable),!*TSt)		// get all threads from a given user from the server thread table
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
724
splitServerThreadsByUser tst=:{staticInfo}
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
725
# userid 				= staticInfo.currentUserId
726 727
# (serverThreads,tst)	= ServerThreadTableStorage id tst						// get thread table on server
# splitedthreads		= filterZip (\thr -> thr.thrUserId == userid &&			// only copy relevant part of thread table to client
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
728
							      (thr.thrKind == ClientServerThread || thr.thrKind == ClientThread)) serverThreads ([],[])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
729
= (splitedthreads,tst)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
730 731 732 733 734
where
	filterZip pred [] accu = accu
	filterZip pred [x:xs] (yes,no)
	| pred x = filterZip pred xs ([x:yes],no)
	| otherwise = filterZip pred xs (yes,[x:no])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
735

736
copyThreadTableFromClient :: !GlobalInfo !*TSt -> !*TSt							// copies all threads for this user from client to server thread table
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
737 738
copyThreadTableFromClient versioninfo tst
=	IF_ClientServer										
739
		(IF_ClientTasks id (copyThreadTableFromClient` versioninfo) tst)		// only iff we are on the server the copied can be made
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
740 741
		tst

742
copyThreadTableFromClient` :: !GlobalInfo !*TSt -> !*TSt						// copies all threads for this user from client to server thread table
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
743
copyThreadTableFromClient` {newThread,deletedThreads} tst
744
# ((clienttableOnServer,otherClientsTable),tst)
745
						= splitServerThreadsByUser tst							// get latest thread table stored on server
746
# (clienttableOnClient,tst)		
747
						= ClientThreadTableStorage id tst						// get latest thread table stored on client
748
# clienttableOnClient	= case deletedThreads of
749
								[] -> 	clienttableOnClient						// remove threads in client table which have been deleted by global effects											
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
750
								_  -> 	[client 
751
										\\ client <- clienttableOnClient | not (isChildOf client.thrTaskNr deletedThreads) 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
752
										]
753 754 755 756 757 758 759 760 761
# (clienttableOnClient,tst)		
						= ClientThreadTableStorage (\_ -> []) tst				// clear thread table stored on client
# tst					= deleteAllSubTasks deletedThreads tst					// remove corresponding tasks
# thrNrsActiveOnClient	= [thread.thrTaskNr \\ thread <- clienttableOnClient]	// all active thread numbers on client
# newClientsOnServer	= [thread \\ thread <- clienttableOnServer | not (isMember (thread.thrTaskNr) thrNrsActiveOnClient)]
# newtable				= newClientsOnServer ++ clienttableOnClient ++ otherClientsTable			// determine new thread situation
# (serverThreads,tst)	= ServerThreadTableStorage (\_ -> newtable) tst			// store table on server
= tst

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
762 763
findThreadInTable :: !ThreadKind !TaskNr *TSt -> *(Maybe (!Int,!TaskThread),*TSt)// find thread that belongs to given tasknr
findThreadInTable threadkind tasknr tst
764 765 766 767 768 769 770 771 772
# (table,tst)	= ThreadTableStorage id tst										// read thread table
# pos			= lookupThread tasknr 0 table									// look if there is an entry for this task
| pos < 0		= (Nothing, tst)
= (Just (pos,table!!pos),tst) 
where
	lookupThread :: !TaskNr !Int !ThreadTable -> Int
	lookupThread tableKey n []			
		= -1																	// no, cannot find thread
	lookupThread tasknrToFind n [entry:next]
773
		| (showTaskNr tasknrToFind == showTaskNr entry.thrTaskNr &&	foundThread threadkind entry.thrKind) =  n	// yes, thread is administrated
774 775
		= lookupThread tasknrToFind (inc n) next

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
776 777
// TODO foundThread kan niet kloppen !!!

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
778
	foundThread ServerThread     		ServerThread 	   		= True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
779 780
	foundThread ServerThread     		ClientServerThread 	   	= True
	foundThread ServerThread     		ClientThread	 	   	= True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
781
	foundThread ClientThread    		ClientThread