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

3
import StdMisc, StdArray, StdList, StdChar, StdFile, StdBool
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, TuningCombinators
11
import CommandLine
ecrombag's avatar
ecrombag committed
12
import Directory
13

14
import Http, HttpUtil
15
from HttpServer import :: HTTPServerControl(..), :: HTTPServerOption(..)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
16

17
import Setup
18

19
import ApplicationService, SessionService, WorkflowService, TaskService, UserService, DocumentService
20 21
import HtmlUtil

22
import Config, TSt
23

24 25
from UserAdmin import userAdministration

26
PATH_SEP :== "\\"
27

28
// The iTasks engine consist of a set of HTTP request handlers
29
engine :: !(Maybe Config) [Workflow] -> [(!String -> Bool, HTTPRequest *World -> (!HTTPResponse, !HTTPServerControl, !*World))] 
Bas Lijnse's avatar
Bas Lijnse committed
30
engine mbConfig userFlows	
31 32
	= case mbConfig of
		Just config
33
			= handlers config
34
		Nothing
35
			= [(\_ -> True, setupHandler handlers)]
36
where
37
	handlers config
Bas Lijnse's avatar
Bas Lijnse committed
38
		= [
Bas Lijnse's avatar
Bas Lijnse committed
39 40
		  // Handler to stop the server nicely
		   ((==) "/stop", handleStopRequest)
Bas Lijnse's avatar
Bas Lijnse committed
41
		  // Webservices
42
		  ,(startsWith config.serverPath, serviceDispatch config flows)
43 44
		  ,(\_ -> True, handleStaticResourceRequest config)
		  ]	
45
	//Always add the workflows for administering the itask system
Bas Lijnse's avatar
Bas Lijnse committed
46
	flows = userAdministration ++ userFlows
47

48 49
	serviceDispatch config flows req world
		# tst				= initTSt req config flows world
50 51 52
		# reqpath			= (http_urldecode req.req_path)
		# reqpath			= reqpath % (size config.serverPath, size reqpath)
		# (response,tst) = case (split "/" reqpath) of
53 54
			[""]								= (redirectResponse (req.req_path +++ "/html"), tst)
			["","html"]							= (overviewResponse, tst)
55
			["",format:path]
56 57 58 59
				# html = format == "html"
				# json = format == "json"
				| html || json
					= case path of
60
						
61 62 63 64 65
						["application":path]	= applicationService req.req_path html path req tst
						["sessions":path]		= sessionService req.req_path html path req tst
						["workflows":path]		= workflowService req.req_path html path req tst
						["tasks":path]			= taskService req.req_path html path req tst
						["users":path]			= userService req.req_path html path req tst
66
						["documents":path]		= documentService req.req_path html path req tst
67
						_						= (notFoundResponse req, tst)
68 69 70 71 72 73
				| otherwise
					= (notFoundResponse req, tst)
			_
				= (notFoundResponse req, tst)
		# tst		= flushStore tst
		= (response, HTTPServerContinue, finalizeTSt tst)
74

75
workflow :: !String !(Task a) -> Workflow | iTask a
76
workflow path task =
77
	{ Workflow
78
	| path	= path
79
	, roles	= []
80
	, thread = createThread (task <<@ Subject name)
81
	}
82 83 84
where
	name = last (split "/" path)
	
85 86 87 88 89
restrictedWorkflow :: !String ![Role] !(Task a) -> Workflow | iTask a
restrictedWorkflow path roles task =
	{ Workflow
	| path	= path
	, roles	= roles
90
	, thread = createThread task
91 92
	}

93
config :: !*World -> (!Maybe Config,!*World)
Bas Lijnse's avatar
Bas Lijnse committed
94 95 96 97
config world
	# (appName,world) = determineAppName world
	= loadConfig appName world

98 99 100
// 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...
101
handleStaticResourceRequest :: !Config !HTTPRequest *World -> (!HTTPResponse,!HTTPServerControl,!*World)
102
handleStaticResourceRequest config req world
103
	# path					= if (req.req_path == "/") "/index.html" req.req_path
104
	# filename				= config.clientPath +++ filePath path
105 106 107 108 109
	# (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))]
110
							   	,rsp_data = content}, HTTPServerContinue, world)
111 112 113 114 115
	# 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),
116 117
											   ("Content-Length", toString (size content))											   
											   ]
118
							   	,rsp_data = content}, HTTPServerContinue, world)						   								 	 							   
119
	= (notFoundResponse req,HTTPServerContinue,world)
120 121 122
where
	//Translate a URL path to a filesystem path
	filePath path = ((replaceSubString "/" PATH_SEP) o (replaceSubString ".." "")) path
123 124 125

handleStopRequest :: HTTPRequest *World -> (!HTTPResponse,!HTTPServerControl,!*World)
handleStopRequest req world = ({http_emptyResponse & rsp_data = "Server stopped..."},HTTPServerStop, world)
126

Bas Lijnse's avatar
Bas Lijnse committed
127 128
initTSt :: !HTTPRequest !Config ![Workflow] !*World -> *TSt
initTSt request config flows world
129
	# (appName,world) 			= determineAppName world
ecrombag's avatar
ecrombag committed
130 131 132 133 134 135
	# (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
136
	# datestr					= (toString date.Date.year)+++"."+++(padZero date.Date.month)+++"."+++(padZero date.Date.day)+++"-"+++(padZero time.Time.hours)+++"."+++(padZero time.Time.minutes)+++"."+++(padZero time.Time.seconds)
137
	# ((ok,datapath),world)		= pd_StringToPath appName world
138 139 140
	# (err,world)				= createDirectory datapath world
	| err <> NoDirError 
		&& err <> AlreadyExists	= abort "Cannot create data directory"
141
	= mkTSt appName config request flows (createStore (appName +++ "\\" +++ datestr)) world
ecrombag's avatar
ecrombag committed
142
where 
143
	padZero number = (if (number < 10) "0" "") +++ toString number
ecrombag's avatar
ecrombag committed
144

145
finalizeTSt :: !*TSt -> *World
146
finalizeTSt tst=:{TSt|iworld={IWorld|world}} = world
147

ecrombag's avatar
ecrombag committed
148 149 150 151 152 153
// Determines the server executables path
determineAppPath :: !*World -> (!String, !*World)
determineAppPath world
	# (args,world) = getCommandLine world
	= (hd args,world)

154 155 156 157 158 159
// Determines the server executables name
determineAppName :: !*World -> (!String,!*World)
determineAppName world 
	# (args,world)	= getCommandLine world
	= (strip (hd args),world)
where
160
	strip path = let executable = last (split PATH_SEP path) in executable % (0, size executable - 5)