Engine.icl 7.1 KB
Newer Older
1 2
implementation module Engine

3
import StdMisc, StdArray, StdList, StdChar, StdFile
ecrombag's avatar
ecrombag committed
4

5
from StdFunc import o
ecrombag's avatar
ecrombag committed
6 7
from StdLibMisc import ::Date{..}, ::Time{..}

8
import Store, UserDB, ProcessDB, SessionDB
9
import Text, Util
10
import CoreCombinators
11
import CommandLine
ecrombag's avatar
ecrombag committed
12
import Directory
13

14
import Http, HttpUtil
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
15

16
import AuthenticationHandler, DeauthenticationHandler
Bas Lijnse's avatar
Bas Lijnse committed
17
import NewListHandler, NewStartHandler, WorkListHandler, WorkTabHandler, PropertyHandler, UserListHandler
18
import TaskTreeForestHandler, ProcessTableHandler
19
import RPCHandlers, DocumentHandler
20

21
import Config, TSt
22

23 24
from UserAdmin import userAdministration

25
PATH_SEP :== "\\"
26

27
// The iTasks engine consist of a set of HTTP request handlers
Bas Lijnse's avatar
Bas Lijnse committed
28
engine :: Config [Workflow] -> [(!String -> Bool, HTTPRequest *World -> (!HTTPResponse, !*World))] 
29
engine config userflows 
30 31 32 33 34 35 36 37 38 39 40 41
	= [((==) (config.serverPath +++ "/authenticate"), handleAnonRequest config flows handleAuthenticationRequest)
	  ,((==) (config.serverPath +++ "/deauthenticate"), handleSessionRequest config flows handleDeauthenticationRequest)							
	  ,((==) (config.serverPath +++ "/new/list"), handleSessionRequest config flows handleNewListRequest)
	  ,((==) (config.serverPath +++ "/new/start"), handleSessionRequest config flows handleNewStartRequest)
	  ,((==) (config.serverPath +++ "/work/list"), handleSessionRequest config flows handleWorkListRequest)
	  ,((==) (config.serverPath +++ "/work/tab"), handleSessionRequest config flows handleWorkTabRequest)
	  ,((==) (config.serverPath +++ "/work/property"), handleSessionRequest config flows handlePropertyRequest)
	  ,((==) (config.serverPath +++ "/data/users"), handleSessionRequest config flows handleUserListRequest)
	  ,((==) (config.serverPath +++ "/rpc/request"), handleSessionRequest config flows handleRPCListRequest)
	  ,((==) (config.serverPath +++ "/rpc/response"), handleSessionRequest config flows handleRPCUpdates)
	  ,((==) (config.serverPath +++ "/debug/taskforest"), handleSessionRequest config flows handleTaskForestRequest)
	  ,((==) (config.serverPath +++ "/debug/processtable"), handleSessionRequest config flows handleProcessTableRequest)
42 43
	  ,((==) (config.serverPath +++ "/document/download"), handleSessionRequest config flows handleDocumentDownloadRequest)
	  ,((startsWith) (config.serverPath +++ "/document/download/link"), handleSessionRequest config flows handleDocumentDownloadLinkRequest)
44
	  ,((startsWith) (config.serverPath +++ "/document/preview/link"), handleSessionRequest config flows handleDocumentPreviewLinkRequest)  
Bas Lijnse's avatar
Bas Lijnse committed
45
	  ,(\_ -> True, handleStaticResourceRequest)
46
	  ]
47 48 49
where
	//Always add the workflows for administering the itask system
	flows = userflows ++ userAdministration
50

51
workflow :: String (Task a) -> Workflow | iTask a
52
workflow path task =
53 54
	{ Workflow
	| name	= path
55 56 57 58 59
	, label = last (split "/" path)
	, roles	= []
	, mainTask = task >>| return Void
	}

Bas Lijnse's avatar
Bas Lijnse committed
60 61 62 63 64
config :: !*World -> (!Config,!*World)
config world
	# (appName,world) = determineAppName world
	= loadConfig appName world

65 66 67
// 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...
68 69
handleStaticResourceRequest :: !HTTPRequest *World -> (!HTTPResponse, !*World)
handleStaticResourceRequest req world
70 71
	# (appName,world)		= determineAppName world
	# (config,world)		= loadConfig appName world
72
	# path					= if (req.req_path == "/") "/index.html" req.req_path
73
	# filename				= config.clientPath +++ filePath path
74 75 76 77 78
	# (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))]
79 80 81 82 83 84
							   	,rsp_data = content}, world)
	# filename				= config.staticPath +++ filePath path
	# (type, world)			= http_staticFileMimeType filename world
	# (ok, content, world)	= http_staticFileContent filename world
	|  ok 					= ({rsp_headers = [("Status","200 OK"),
											   ("Content-Type", type),
85 86
											   ("Content-Length", toString (size content))											   
											   ]
87
							   	,rsp_data = content}, world)						   								 	 							   
88
	= http_notfoundResponse req world
89 90 91 92
where
	//Translate a URL path to a filesystem path
	filePath path = ((replaceSubString "/" PATH_SEP) o (replaceSubString ".." "")) path
	
Bas Lijnse's avatar
Bas Lijnse committed
93 94 95
handleAnonRequest :: Config [Workflow] (HTTPRequest *TSt -> (!HTTPResponse, !*TSt)) !HTTPRequest *World -> (!HTTPResponse, !*World)
handleAnonRequest config flows handler request world
	# tst						= initTSt request config flows world
96 97
	# (response, tst)			= handler request tst
	# world						= finalizeTSt tst
98 99
	= (response, world)

Bas Lijnse's avatar
Bas Lijnse committed
100 101 102
handleSessionRequest :: Config [Workflow] (HTTPRequest *TSt -> (!HTTPResponse, !*TSt)) !HTTPRequest *World -> (!HTTPResponse, !*World)
handleSessionRequest config flows handler request world
	# tst						= initTSt request config flows world
Bas Lijnse's avatar
Bas Lijnse committed
103
	# sessionId					= http_getValue "_session" (request.arg_get ++ request.arg_post) ""
104
	# (mbSession,timeout,tst=:{staticInfo})	= restoreSession sessionId tst
105
	= case mbSession of
106
		Nothing
107
			# world				= finalizeTSt tst
108
			= ({http_emptyResponse & rsp_data = mkSessionFailureResponse timeout}, world)
109
		(Just session)
110 111 112 113
			# tst					= {tst & staticInfo = {staticInfo & currentSession = session}}
			# (response,tst)		= handler request tst
			# tst					= flushStore tst
			# world					= finalizeTSt tst
114 115
			= (response, world)		
where
116
	mkSessionFailureResponse to = "{\"success\" : false, \"session\": false, \"error\" : \"" +++ (if to "Your session timed out" "Failed to load session") +++ "\"}"
117
 
Bas Lijnse's avatar
Bas Lijnse committed
118 119
initTSt :: !HTTPRequest !Config ![Workflow] !*World -> *TSt
initTSt request config flows world
120
	# (appName,world) 			= determineAppName world
ecrombag's avatar
ecrombag committed
121 122 123 124 125 126
	# (pathstr,world)			= determineAppPath world
	# ((ok, path),world)		= pd_StringToPath (pathstr) world
	| not ok					= abort "Cannot find the executable."
	# ((err,info),world)		= getFileInfo path world
	| err <> NoDirError			= abort "Cannot get executable info."
	# (date,time)				= info.pi_fileInfo.lastModified
ecrombag's avatar
ecrombag committed
127
	# datestr					= (toString date.Date.year)+++(addPrefixZero date.Date.month)+++(addPrefixZero date.Date.day)+++"-"+++(addPrefixZero time.Time.hours)+++(addPrefixZero time.Time.minutes)+++(addPrefixZero time.Time.seconds)
128
	= mkTSt appName config request (abort "session not active yet") flows (createStore (appName +++ "-systemStore")) (createStore (appName +++ "-dataStore-" +++ datestr)) (createStore (appName +++ "-documentStore-" +++ datestr)) world
ecrombag's avatar
ecrombag committed
129 130 131 132 133
where 
	addPrefixZero number
	| number < 10 = "0"+++toString number
	| otherwise = toString number

134 135
finalizeTSt :: !*TSt -> *World
finalizeTSt tst=:{TSt|world} = world
136

ecrombag's avatar
ecrombag committed
137 138 139 140 141 142
// Determines the server executables path
determineAppPath :: !*World -> (!String, !*World)
determineAppPath world
	# (args,world) = getCommandLine world
	= (hd args,world)

143 144 145 146 147 148
// Determines the server executables name
determineAppName :: !*World -> (!String,!*World)
determineAppName world 
	# (args,world)	= getCommandLine world
	= (strip (hd args),world)
where
149
	strip path = let executable = last (split PATH_SEP path) in executable % (0, size executable - 5)
150 151 152