Engine.icl 12.9 KB
Newer Older
1
implementation module iTasks.Engine
2

3 4
import Data.Func
import Data.Functor
5
import Data.List
6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
import Data.Queue
import Internet.HTTP
import StdEnv
import System.CommandLine
import System.Directory
import System.File
import System.FilePath
import System.GetOpt
import System.OS
import Text
import iTasks.Internal.Distributed.Symbols
import iTasks.Internal.EngineTasks
import iTasks.Internal.IWorld
import iTasks.Internal.SDS
import iTasks.Internal.SDSService
import iTasks.Internal.TaskServer
import iTasks.Internal.TaskStore
import iTasks.Internal.Util
import iTasks.SDS.Sources.System
25
import iTasks.WF.Combinators.Common
26
import iTasks.WF.Definition
27
import iTasks.WF.Tasks.Core
28
import iTasks.WF.Tasks.SDS
29
import iTasks.WF.Tasks.System
Mart Lubbers's avatar
Mart Lubbers committed
30
import iTasks.WF.Derives
31

32
import qualified Data.Map as DM
33
import Data.Map.GenJSON
34

35 36
from TCPIP import :: Timeout
from StdFunc import :: St, seqList
37

Mart Lubbers's avatar
Mart Lubbers committed
38 39
MAX_EVENTS 		        :== 5

40
derive class iTask EngineOptions
41

42
doTasks :: a !*World -> *World | Startable a
Bas Lijnse's avatar
Bas Lijnse committed
43
doTasks startable world = doTasksWithOptions (defaultEngineCLIOptions startable) world
44

Bas Lijnse's avatar
Bas Lijnse committed
45 46
doTasksWithOptions :: ([String] EngineOptions -> MaybeError [String] (a,EngineOptions)) !*World -> *World | Startable a
doTasksWithOptions initFun world
47 48 49
	# (cli,world)                = getCommandLine world
	# (options,world)            = defaultEngineOptions world
	# mbOptions                  = initFun cli options
50
	| mbOptions =:(Error _)      = show (fromError mbOptions) (setReturnCode 1 world)
Bas Lijnse's avatar
Bas Lijnse committed
51
	# (startable,options)        = fromOk mbOptions
52
	# mbIWorld                   = createIWorld options world
53 54 55 56
	| mbIWorld =: Left _
		# (Left (err, world)) = mbIWorld
		= show [err] (setReturnCode 1 world)
	# (Right iworld)             = mbIWorld
57
	# (symbolsResult, iworld)    = initSymbolsShare options.distributed options.appName iworld
58
	| symbolsResult =: (Error _) = show ["Error reading symbols while required: " +++ fromError symbolsResult] (setReturnCode 1 (destroyIWorld iworld))
Bas Lijnse's avatar
Bas Lijnse committed
59 60
	# iworld = if (hasDup (requestPaths startable))
		(iShow ["Warning: duplicate paths in the web tasks: " +++ join ", " ["'" +++ p +++ "'"\\p<-requestPaths startable]] iworld)
61
		iworld
Bas Lijnse's avatar
Bas Lijnse committed
62
	# iworld                     = serve (startupTasks startable options) (tcpTasks startable options.serverPort options.keepaliveTime) (timeout options.timeout) iworld
63
	= destroyIWorld iworld
64
where
Bas Lijnse's avatar
Bas Lijnse committed
65 66 67 68
	requestPaths startable = [path\\{path}<-webTasks startable]
	webTasks startable = [t \\ WebTask t <- toStartable startable]
	startupTasks startable {distributed, sdsPort}
		=  if (webTasks startable) =:[]
69 70 71 72 73
		   //if there are no webtasks: stop when stable
		   [systemTask (startTask stopOnStable)]
		   //if there are: show instructions andcleanup old sessions
		   [startTask viewWebServerInstructions
		   ,systemTask (startTask removeOutdatedSessions)]
Mart Lubbers's avatar
cleanup  
Mart Lubbers committed
74
		//If distributed, start sds service task
75
		++ (if distributed [systemTask (startTask (sdsServiceTask sdsPort))] [])
76
		++ [systemTask (startTask flushWritesWhenIdle)
Mart Lubbers's avatar
cleanup  
Mart Lubbers committed
77
		//Start all startup tasks
78
		   :[t \\ StartupTask t <- toStartable startable]]
Mart Lubbers's avatar
cleanup  
Mart Lubbers committed
79

80
	startTask t = {StartupTask|attributes=defaultValue,task=TaskWrapper t}
81
	systemTask t = {StartupTask|t&attributes='DM'.put "system" (JSONBool True) t.StartupTask.attributes}
Mart Lubbers's avatar
cleanup  
Mart Lubbers committed
82

Haye Böhm's avatar
Haye Böhm committed
83
	initSymbolsShare False _ iworld = (Ok (), iworld)
Haye Böhm's avatar
Haye Böhm committed
84
	initSymbolsShare True appName iworld = case storeSymbols (IF_WINDOWS (appName +++ ".exe") appName) iworld of
Haye Böhm's avatar
Haye Böhm committed
85
		(Error (e, s), iworld) = (Error s, iworld)
86
		(Ok noSymbols, iworld) = (Ok (),  {iworld & world = show ["Read number of symbols: " +++ toString noSymbols] iworld.world})
Haye Böhm's avatar
Haye Böhm committed
87

88
	//Only run a webserver if there are tasks that are started through the web
Bas Lijnse's avatar
Bas Lijnse committed
89 90
	tcpTasks startable serverPort keepaliveTime
		| (webTasks startable)=: [] = []
91
		| otherwise
Bas Lijnse's avatar
Bas Lijnse committed
92
			= [(serverPort,httpServer serverPort keepaliveTime (engineWebService (webTasks startable)) taskOutput)]
93

94
	// The iTasks engine consist of a set of HTTP Web services
95
	engineWebService :: [WebTask] -> [WebService (Map InstanceNo TaskOutput) (Map InstanceNo TaskOutput)]
96 97 98 99 100 101 102 103 104 105 106 107 108
	engineWebService webtasks =
		[taskUIService webtasks
		,documentService
		,staticResourceService [path \\ {WebTask|path} <- webtasks]
		]

	show :: ![String] !*World -> *World
	show lines world
		# (console,world)	= stdio world
		# console			= seqSt (\s c -> fwrites (s +++ OS_NEWLINE) c) lines console
		# (_,world)			= fclose console world
		= world

Bas Lijnse's avatar
Bas Lijnse committed
109 110
defaultEngineCLIOptions :: a [String] EngineOptions -> MaybeError [String] (a, EngineOptions)
defaultEngineCLIOptions tasks [argv0:argv] defaults
111 112 113 114 115
	# (settings, positionals, errs) = getOpt Permute opts argv
	| not (errs =: []) = Error errs
	| not (positionals =: []) = Error ["Positional arguments not allowed"]
	= case foldl (o) id settings (Just defaults) of
		Nothing = (Error [usageInfo ("Usage " +++ argv0 +++ "[OPTIONS]") opts])
Bas Lijnse's avatar
Bas Lijnse committed
116
		Just settings = Ok (tasks,settings)
117 118 119
where
	opts :: [OptDescr ((Maybe EngineOptions) -> Maybe EngineOptions)]
	opts =
120
		[ Option ['?'] ["help"] (NoArg (\_->Nothing))
121 122
			"Display this message"
		, Option ['p'] ["port"] (ReqArg (\p->fmap \o->{o & serverPort=toInt p}) "PORT")
123
			("Specify the HTTP port (default: " +++ toString defaults.serverPort +++ ")")
124 125
		, Option [] ["timeout"] (OptArg (\mp->fmap \o->{o & timeout=fmap toInt mp}) "MILLISECONDS")
			"Specify the timeout in ms (default: 500)\nIf not given, use an indefinite timeout."
126
		, Option [] ["allowed-hosts"] (ReqArg (\p->fmap \o->{o & allowedHosts = if (p == "") [] (split "," p)}) "IPADRESSES")
127 128
			("Specify a comma separated white list of hosts that are allowed to connected to this application\ndefault: "
			 +++ join "," defaults.allowedHosts)
129 130
		, Option [] ["keepalive"] (ReqArg (\p->fmap \o->{o & keepaliveTime={tv_sec=toInt p,tv_nsec=0}}) "SECONDS")
			"Specify the keepalive time in seconds (default: 300)"
131 132
		, Option [] ["maxevents"] (ReqArg (\p->fmap \o->{o & maxEvents=toInt p}) "NUM")
			"Specify the maximum number of events to process per loop (default: 5)"
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
		, Option [] ["sessiontime"] (ReqArg (\p->fmap \o->{o & sessionTime={tv_sec=toInt p,tv_nsec=0}}) "SECONDS")
			"Specify the expiry time for a session in seconds (default: 60)"
		, Option [] ["autolayout"] (NoArg (fmap \o->{o & autoLayout=True}))
			"Enable autolayouting (default)"
		, Option [] ["no-autolayout"] (NoArg (fmap \o->{o & autoLayout=False}))
			"Disable autolayouting"
		, Option [] ["persist-tasks"] (NoArg (fmap \o->{o & persistTasks=True}))
			"Enable the persistence of tasks"
		, Option [] ["no-persist-tasks"] (NoArg (fmap \o->{o & persistTasks=False}))
			"Disable the persistence of tasks (default)"
		, Option [] ["webdir"] (ReqArg (\p->fmap \o->{o & webDirPath=p}) "PATH")
			("Specify the folder containing static web content\ndefault: " +++ defaults.webDirPath)
		, Option [] ["storedir"] (ReqArg (\p->fmap \o->{o & storeDirPath=p}) "PATH")
			("Specify the folder containing the data stores\ndefault: " +++ defaults.storeDirPath)
		, Option [] ["tempdir"] (ReqArg (\p->fmap \o->{o & tempDirPath=p}) "PATH")
			("Specify the folder containing the temporary files\ndefault: " +++ defaults.tempDirPath)
149 150
		, Option [] ["bytecodepath"] (ReqArg (\p->fmap \o->{o & byteCodePath=p}) "PATH")
			("Specify the app's bytecode file\ndefault: " +++ defaults.byteCodePath)
151 152
		, Option [] ["distributed"] (NoArg (fmap \o->{o & distributed=True}))
			"Enable distributed mode (populate the symbols share)"
153 154
		, Option ['s'] ["sdsPort"] (ReqArg (\p->fmap \o->{o & sdsPort=toInt p}) "SDSPORT")
			("Specify the SDS port (default: " +++ toString defaults.sdsPort +++ ")")
155 156
		, Option ['q'] ["quiet"] (NoArg (fmap \o->{o & showInstructions=False}))
			"Don't show instructions to open the browser"
157
		]
158

159 160
onStartup :: (Task a) -> StartableTask | iTask a
onStartup task = StartupTask {StartupTask|attributes = defaultValue, task = TaskWrapper task}
161

162 163 164 165 166 167 168 169
onRequest :: String (Task a) -> StartableTask | iTask a
onRequest path task = WebTask {WebTask|path = path, task = WebTaskWrapper (const task)}

onStartupWithAttributes :: (Task a) TaskAttributes -> StartableTask | iTask a
onStartupWithAttributes task attributes = StartupTask {StartupTask|attributes = attributes, task = TaskWrapper task}

onRequestFromRequest :: String (HTTPRequest -> Task a) -> StartableTask | iTask a
onRequestFromRequest path task = WebTask {WebTask|path = path, task = WebTaskWrapper task}
170 171

class Startable a
Bas Lijnse's avatar
Bas Lijnse committed
172
where
173 174 175
	toStartable :: !a -> [StartableTask]

instance Startable (Task a) | iTask a //Default as web task
176
where
177
	toStartable task = [onRequest "/" task]
178

179
instance Startable (HTTPRequest -> Task a) | iTask a //As web task
180
where
181
	toStartable task = [onRequestFromRequest "/" task]
182

183
instance Startable StartableTask
184
where
185
	toStartable task = [task]
186

187
instance Startable [StartableTask]
188
where
189
	toStartable list = list
190

191 192 193 194
instance Startable (a,b) | Startable a & Startable b
where
	toStartable (x,y) = toStartable x ++ toStartable y

195
viewWebServerInstructions :: Task ()
196 197
viewWebServerInstructions
	=   get applicationOptions
198 199
	>>- \{EngineOptions|appName,serverPort,showInstructions}
		| showInstructions ->
200 201 202 203 204 205 206
			traceValue (join OS_NEWLINE
				["*** " +++ appName +++ " HTTP server ***"
				,""
				,"Running at http://localhost" +++
					if (serverPort == 80)
						"/"
						(":" +++ toString serverPort +++ "/")
207 208
				]) @! ()
		| otherwise -> treturn ()
209

210 211
defaultEngineOptions :: !*World -> (!EngineOptions,!*World)
defaultEngineOptions world
212
	# (appPath,world)    = determineAppPath world
213 214
	# (appVersion,world) = determineAppVersion appPath world
	# appDir             = takeDirectory appPath
215
	# appName            = (if (takeExtension appPath == "exe") dropExtension id o dropDirectory) appPath
216
	# options =
217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
		{ appName          = appName
		, appPath          = appPath
		, appVersion       = appVersion
		, serverPort       = IF_POSIX_OR_WINDOWS 8080 80
		, serverUrl        = "http://localhost/"
		, allowedHosts     = ["127.0.0.1"]
		, keepaliveTime    = {tv_sec=300,tv_nsec=0} // 5 minutes
		, sessionTime      = {tv_sec=60,tv_nsec=0}  // 1 minute, (the client pings every 10 seconds by default)
		, persistTasks     = False
		, autoLayout       = True
		, distributed      = False
		, maxEvents        = 5
		, sdsPort          = 9090
		, timeout          = Nothing//Just 500
		, webDirPath       = appDir </> appName +++ "-www"
		, storeDirPath     = appDir </> appName +++ "-data" </> "stores"
		, tempDirPath      = appDir </> appName +++ "-data" </> "tmp"
		, byteCodePath     = appDir </> appName +++ ".bc"
		, showInstructions = True
236 237 238
		}
	= (options,world)

ecrombag's avatar
ecrombag committed
239
// Determines the server executables path
240
determineAppPath :: !*World -> (!FilePath, !*World)
ecrombag's avatar
ecrombag committed
241
determineAppPath world
242
	# ([arg:_],world) = getCommandLine world
243
	| dropDirectory arg <> "ConsoleClient.exe"	= toCanonicalPath arg world
244 245 246
	//Using dynamic linker:
	# (res, world)				= getCurrentDirectory world
	| isError res				= abort "Cannot get current directory."
247
	# currentDirectory			= fromOk res
248 249
	# (res, world)				= readDirectory currentDirectory world
	| isError res				= abort "Cannot read current directory."
250
	# batchfiles				= [f \\ f <- fromOk res | takeExtension f == "bat" ]
251 252 253 254 255
	| isEmpty batchfiles		= abort "No dynamic linker batch file found."
	# (infos, world)			= seqList (map getFileInfo batchfiles) world
	| any isError infos	 		= abort "Cannot get file information."
	= (currentDirectory </> (fst o hd o sortBy cmpFileTime) (zip2 batchfiles infos), world)
	where
256
		cmpFileTime (_,Ok {FileInfo | lastModifiedTime = x})
257
					(_,Ok {FileInfo | lastModifiedTime = y}) = timeGm x > timeGm y
258

259
//By default, we use the modification time of the application executable as version id
260
determineAppVersion :: !FilePath!*World -> (!String,!*World)
261 262
determineAppVersion appPath world
	# (res,world)       = getFileInfo appPath world
263
	| res =: (Error _)  = ("unknown",world)
264 265 266
	# tm				= (fromOk res).lastModifiedTime
	# version           = strfTime "%Y%m%d-%H%M%S" tm
	= (version,world)
267 268 269 270 271 272 273 274 275 276 277 278

timeout :: !(Maybe Timeout) !*IWorld -> (!Maybe Timeout,!*IWorld)
timeout mt iworld = case read taskEvents EmptyContext iworld of
	//No events
	(Ok (ReadingDone (Queue [] [])),iworld=:{sdsNotifyRequests,world})
		# (ts, world) = nsTime world
		= ( minListBy lesser [mt:flatten (map (getTimeoutFromClock ts) ('DM'.elems sdsNotifyRequests))]
		  , {iworld & world = world})
	(Ok (ReadingDone (Queue _ _)), iworld)               = (Just 0,iworld)   //There are still events, don't wait
	(Error _,iworld)            = (Just 500,iworld) //Keep retrying, but not too fast
where
	lesser (Just x) (Just y) = x < y
279 280
	lesser (Just _) Nothing  = True
	lesser _        _        = False
281 282 283 284 285 286

	getTimeoutFromClock :: Timespec (Map SDSNotifyRequest Timespec) -> [Maybe Timeout]
	getTimeoutFromClock now requests = map getTimeoutFromClock` ('DM'.toList requests)
	where
		getTimeoutFromClock` :: (!SDSNotifyRequest, !Timespec) -> Maybe Timeout
		getTimeoutFromClock` (snr=:{cmpParam=(ts :: ClockParameter Timespec)}, reqTimespec)
287
			| dependsOnClock snr && ts.interval <> zero
288 289 290 291 292
				# fire = iworldTimespecNextFire now reqTimespec ts
				= Just (max 0 (toMs fire - toMs now))
			= mt
		getTimeoutFromClock` _ = mt

293
	dependsOnClock :: !SDSNotifyRequest -> Bool
294
	dependsOnClock snr = indexOf "$IWorld:timespec$" snr.reqSDSId >= 0
295

296
	toMs x = x.tv_sec * 1000 + x.tv_nsec / 1000000