Startup.icl 8.29 KB
Newer Older
1
implementation module Startup
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
2
// *********************************************************************************************************************************
3
// The iTasks library enables the specification of interactive multi-user workflow tasks (iTasks) for the web.
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
4 5 6 7 8 9
// This module contains iTask kernel.
// This library is still under construction - MJP
// *********************************************************************************************************************************
// iTask & iData Concept and Implementation: (c) 2006,2007,2008 - Rinus Plasmeijer
// *********************************************************************************************************************************
//
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
10
import StdEnv
11
import iDataSettings, iDataForms, iDataWidgets, iDataFormlib, iDataTrivial
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
12
import iTasksSettings, InternaliTasksCommon, InternaliTasksThreadHandling
13
import BasicCombinators, iTasksProcessHandling
14

15
import Http, HttpUtil, HttpServer, HttpTextUtil, sapldebug
16
import AuthenticationHandler, DeauthenticationHandler, NewListHandler, NewStartHandler, WorkListHandler, WorkTabHandler //iTasks.Framework.Handlers.*
17
import TaskTreeForestHandler, ProcessTableHandler, ThreadTableHandler
18
import TaskTree, TaskTreeFilters
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
19

20 21
import Session //iTasks.Framework.Session

22 23 24
import JSON
derive JSONDecode HtmlState, StorageFormat, Lifespan

25 26 27
// ******************************************************************************************************
// *** Server / Client startup
// ******************************************************************************************************
28 29
startTaskEngine :: !(LabeledTask a) !Int !*World -> *World  	| iData a
startTaskEngine mainTask mainUser world = doHtmlServer mainTask mainUser world		
30

31 32
doHtmlServer :: (LabeledTask a) !Int !*World -> *World | iData a
doHtmlServer mainTask uid world
33 34
| ServerKind == Internal
	# world	= instructions world
35
	= startServer mainTask uid world	// link in the Clean http 1.0 server	
36
//| ServerKind == CGI					// build as CGI application
37 38 39 40 41 42 43
| otherwise
	= unimplemented world
where
	instructions :: *World -> *World
	instructions world
		# (console, world)	= stdio world
		# console			= fwrites "HTTP server started...\n" console
44
		# console			= fwrites ("Please point your browser to http://localhost/\n") console
45 46 47 48 49 50 51 52 53 54 55
		# (_,world)			= fclose console world
		= world
		
	unimplemented :: *World -> *World
	unimplemented world
		# (console, world)	= stdio world
		# console			= fwrites "The chosen server mode is not supported.\n" console
		# console			= fwrites "Please select ServerKind Internal in iDataSettings.dcl.\n" console
		# (_,world)			= fclose console world
		= world

56 57
startServer :: (LabeledTask a) !Int !*World -> *World | iData a
startServer mainTask mainUser world
58
	# options = ServerOptions ++ (if TraceHTTP [HTTPServerOptDebug True] [])
59 60
	= http_startServer options   [((==) "/handlers/authenticate", handleAnonRequest handleAuthenticationRequest)
								 ,((==) "/handlers/deauthenticate", handleSessionRequest handleDeauthenticationRequest)							
61 62
								 ,((==) "/handlers/new/list", handleSessionRequest (handleNewListRequest mainTask mainUser))
								 ,((==) "/handlers/new/start", handleSessionRequest (handleNewStartRequest mainTask mainUser))
63 64 65 66 67
								 ,((==) "/handlers/work/list", handleSessionRequest (handleWorkListRequest mainTask mainUser))
								 ,((==) "/handlers/work/tab", handleSessionRequest (handleWorkTabRequest mainTask mainUser))
								 ,((==) "/handlers/debug/tasktreeforest", handleSessionRequest (handleTaskTreeForestRequest mainTask mainUser))
								 ,((==) "/handlers/debug/processtable", handleSessionRequest (handleProcessTableRequest mainTask mainUser))
								 ,((==) "/handlers/debug/threadtable", handleSessionRequest (handleThreadTableRequest mainTask mainUser))
68
								 ,(\_ -> True, handleStaticResourceRequest)
69 70 71 72 73 74
								 ] world

// Request handler which serves static resources from the application directory,
// or a system wide default directory if it is not found locally.
// This request handler is used for serving system wide javascript, css, images, etc...

75 76
handleStaticResourceRequest :: !HTTPRequest *World -> (!HTTPResponse, !*World)
handleStaticResourceRequest req world
77 78
	# path					= if (req.req_path == "/") "/index.html" req.req_path
	# filename				= MyAbsDir +++ path	
79 80 81 82 83 84
	# (type, world)			= http_staticFileMimeType filename world
	# (ok, content, world)	= http_staticFileContent filename world
	| ok					= ({rsp_headers = [("Status","200 OK"),
											   ("Content-Type", type),
											   ("Content-Length", toString (size content))]
							   ,rsp_data = content}, world)
85
	# filename				= ResourceDir +++ path
86 87 88 89 90 91 92 93
	# (type, world)			= http_staticFileMimeType filename world
	# (ok, content, world)	= http_staticFileContent filename world
	|  ok 					= ({rsp_headers = [("Status","200 OK"),
											   ("Content-Type", type),
											   ("Content-Length", toString (size content))]
							   	,rsp_data = content}, world)		 							   
	= http_notfoundResponse req world

94

95 96 97 98 99 100 101 102 103 104 105
handleAnonRequest :: (HTTPRequest *HSt -> (!HTTPResponse, !*HSt)) !HTTPRequest *World -> (!HTTPResponse, !*World)
handleAnonRequest handler request world
	# hst						= initHSt request world
	# (response, hst)			= handler request hst
	# world						= finalizeHSt hst
	= (response, world)

handleSessionRequest :: (HTTPRequest Session *HSt -> (!HTTPResponse, !*HSt)) !HTTPRequest *World -> (!HTTPResponse, !*World)
handleSessionRequest handler request world
	# hst						= initHSt request world
	# sessionId					= http_getValue "session" (request.arg_get ++ request.arg_post) ""
106
	# (mbSession,timeout,hst)	= restoreSession sessionId hst
107
	= case mbSession of
108 109
		Nothing
			# hst				= storeStates hst	
110
			# world				= finalizeHSt hst
111
			= ({http_emptyResponse & rsp_data = mkSessionFailureResponse timeout}, world)
112 113
		(Just session)
			# (response, hst)	= handler request session hst 
114
			# hst				= storeStates hst
115
			# world				= finalizeHSt hst
116 117
			= (response, world)		
where
118
	mkSessionFailureResponse to = "{\"success\" : false, \"error\" : \"" +++ (if to "Your session timed out" "Failed to load session") +++ "\"}"
119 120 121

initHSt :: !HTTPRequest !*World -> *HSt
initHSt request world
122 123
	# (gerda,world)				= openDatabase ODCBDataBaseName world						// open the relational database if option chosen
	# (datafile,world)			= openmDataFile DataFileName world							// open the datafile if option chosen
124
	# nworld 					= mkNWorld world datafile gerda								// Wrap all io states in an NWorld state
125 126 127
	# updates					= decodeFormUpdates request.arg_post						// Get the form updates from the post
	# states					= decodeHtmlStates request.arg_post							// Fetch stored states from the post
	# fstates	 				= mkFormStates states updates 								
128
	= mkHSt "" request fstates nworld
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
where
	decodeFormUpdates :: ![(!String, !String)] -> [FormUpdate]
	decodeFormUpdates args = [update \\ (Just update) <- map mbUpdate args]
	where
		mbUpdate (name, value)	= case mbInputId name ((size name) - 1) of
			Nothing			= Nothing
			Just inputid	= Just {FormUpdate | formid = name % (0, (size name) - (size inputid) - 2), inputid = toInt inputid, value = value}
	
		mbInputId "" _		= Nothing
		mbInputId name i
			| name.[i] == '-' && i < ((size name) - 1)	= Just (name % (i + 1, size name))	//Found the marker
			| isDigit name.[i]							= mbInputId name (i - 1)			//Move cursor one position to the left
														= Nothing							//We've hit an unexpected character
	
	decodeHtmlStates :: ![(!String, !String)] -> [HtmlState]
	decodeHtmlStates args = case fromJSON (http_getValue "state" args "") of
		Nothing	= []			//Parsing failed
		Just states = states 
147 148 149 150 151 152 153 154 155


finalizeHSt :: !*HSt -> *World
finalizeHSt hst =:{world = nworld =: {worldC = world, gerda, datafile}}
	# world						= closeDatabase gerda world									// close the relational database if option chosen
	# world						= closemDataFile datafile world								// close the datafile if option chosen
	= world
	
	
156 157
// Database OPTION
openDatabase database world
158
	:== IF_Database (openGerda database world) (abort "Trying to open a relational database while this option is switched off",world)
159
closeDatabase database world
160
	:== IF_Database (closeGerda database world) world
161 162 163

// DataFile OPTION
openmDataFile datafile world
164
	:== IF_DataFile (openDataFile  datafile world) (abort "Trying to open a dataFile while this option is switched off",world)
165
closemDataFile datafile world
166
	:== IF_DataFile (closeDataFile datafile world) world