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

3
import StdMisc, StdArray, StdList, StdOrdList, StdTuple, StdChar, StdFile, StdBool, StdEnum
4 5
import iTasks.WF.Combinators.Common
import iTasks.WF.Tasks.System
6
from StdFunc import o, seqList, ::St, const, id
7
from Data.Map import :: Map
8
from Data.Queue import :: Queue(..)
9
import qualified Data.Map as DM
10
import Data.List, Data.Error, Data.Func, Data.Tuple, Math.Random, Text 
11
import System.Time, System.CommandLine, System.Environment, System.OSError, System.File, System.FilePath, System.Directory
12 13 14
import iTasks.Internal.Util, iTasks.Internal.HtmlUtil
import iTasks.Internal.IWorld, iTasks.Internal.WebService, iTasks.Internal.SDSService
import qualified iTasks.Internal.SDS as SDS
15
import iTasks.UI.Layout, iTasks.UI.Layout.Default
16

17
from iTasks.WF.Combinators.Tune import class tune(..), instance tune ApplyLayout Task, :: ApplyLayout(..)
18
from iTasks.SDS.Combinators.Common import sdsFocus
19

20
import StdInt, StdChar, StdString
21 22
import tcp
import Internet.HTTP, System.Time, System.CommandLine, Data.Func
23

24
import iTasks.Internal.IWorld, iTasks.Internal.TaskEval, iTasks.Internal.TaskStore
25 26
import iTasks.Internal.Util
import iTasks.Internal.TaskServer
27 28
import iTasks.Internal.EngineTasks

29
from iTasks.Extensions.DateTime import toDate, toTime, instance == Date, instance == Time
30

31 32 33
from Data.Set import :: Set, newSet
from Sapl.Linker.LazyLinker import generateLoaderState, :: LoaderStateExt
from Sapl.Linker.SaplLinkerShared import :: SkipSet
34
from Sapl.Target.Flavour import :: Flavour, toFlavour
35

36
from System.OS import IF_POSIX_OR_WINDOWS
37 38
import System.GetOpt
import Data.Functor
39

Mart Lubbers's avatar
Mart Lubbers committed
40 41
MAX_EVENTS 		        :== 5

42 43 44 45 46 47
defaultEngineOptions :: !*World -> (!EngineOptions,!*World)
defaultEngineOptions world
	# (appPath,world)    = determineAppPath world	
	# (appVersion,world) = determineAppVersion appPath world
	# appDir             = takeDirectory appPath
	# appName            = (dropExtension o dropDirectory) appPath
48
	# options =	
49
		{ appName			= appName
50
		, appPath			= appPath
51 52 53
        , appVersion        = appVersion
		, serverPort		= IF_POSIX_OR_WINDOWS 8080 80
        , serverUrl         = "http://localhost/"
54 55
		, 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)
Bas Lijnse's avatar
Bas Lijnse committed
56 57
        , persistTasks      = False
		, autoLayout        = True
Mart Lubbers's avatar
Mart Lubbers committed
58
		, timeout			= Just 500
59 60 61 62 63 64 65 66
		, webDirPath 		= appDir </> appName +++ "-www"
		, storeDirPath      = appDir </> appName +++ "-data" </> "stores"
		, tempDirPath       = appDir </> appName +++ "-data" </> "tmp"
		, saplDirPath 	    = appDir </> appName +++ "-sapl"
		}
	= (options,world)

defaultEngineCLIOptions :: [String] EngineOptions -> (!Maybe EngineOptions,![String])
67 68 69 70 71 72 73 74 75 76
defaultEngineCLIOptions [argv0:argv] defaults
	# (settings, positionals, errs) = getOpt Permute opts argv
	| not (errs =: []) = (Nothing, errs)
	| not (positionals =: []) = (Nothing, ["Positional arguments not allowed"])
	= case foldl (o) id settings (Just defaults) of
		Nothing = (Nothing, [usageInfo ("Usage " +++ argv0 +++ "[OPTIONS]") opts])
		Just settings = (Just settings,
			["*** " +++ settings.appName +++ " HTTP server ***"
			,""
			,"Running at http://localhost" +++ if (settings.serverPort == 80) "/" (":" +++ toString settings.serverPort +++ "/")])
77
where
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
	opts :: [OptDescr ((Maybe EngineOptions) -> Maybe EngineOptions)]
	opts =
		[ Option ['?'] ["help"] (NoArg $ const Nothing)
			"Display this message"
		, Option ['p'] ["port"] (ReqArg (\p->fmap \o->{o & serverPort=toInt p}) "PORT")
			("Specify the HTTP port (default: " +++ toString defaults.serverPort)
		, 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."
		, Option [] ["keepalive"] (ReqArg (\p->fmap \o->{o & keepaliveTime={tv_sec=toInt p,tv_nsec=0}}) "SECONDS")
			"Specify the keepalive time in seconds (default: 300)"
		, 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)
		, Option [] ["sapldir"] (ReqArg (\p->fmap \o->{o & saplDirPath=p}) "PATH")
			("Specify the folder containing the sapl files\ndefault: " +++ defaults.saplDirPath)
106
		]
107

108 109
doTasks :: a !*World -> *World | Startable a
doTasks startable world = doTasksWithOptions defaultEngineCLIOptions startable world
110

111 112
doTasksWithOptions :: ([String] EngineOptions -> (!Maybe EngineOptions,![String])) a !*World -> *World | Startable a
doTasksWithOptions initFun startable world
113 114 115 116
	# (cli,world)			= getCommandLine world
	# (options,world)       = defaultEngineOptions world
	# (mbOptions,msg)       = initFun cli options
	# world                 = show msg world
117 118 119 120 121 122 123 124
	| mbOptions =: Nothing  = world
	# (Just options)		= mbOptions
	# iworld				= createIWorld options world
	# (res,iworld) 			= initJSCompilerState iworld
	| res =:(Error _) 		= show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
	# iworld				= serve startupTasks (tcpTasks options.serverPort options.keepaliveTime)
	                                engineTasks (timeout options.timeout) iworld
	= destroyIWorld iworld
125
where
126 127 128 129 130 131 132 133 134 135
    webTasks = [t \\ WebTask t <- toStartable startable]
	startupTasks = [t \\ StartupTask t <- toStartable startable]
	hasWebTasks = not (webTasks =: [])

	//Only run a webserver if there are tasks that are started through the web
	tcpTasks serverPort keepaliveTime
		| webTasks =: [] = []
		| otherwise
			= [(serverPort,httpServer serverPort keepaliveTime (engineWebService webTasks) taskOutput)]
	
Mart Lubbers's avatar
Mart Lubbers committed
136 137 138
	engineTasks =
 		[BackgroundTask updateClock
		,BackgroundTask (processEvents MAX_EVENTS)
139 140 141 142 143 144
		:if (webTasks =: [])
			[BackgroundTask removeOutdatedSessions
		 	,BackgroundTask flushWritesWhenIdle
			]
			[BackgroundTask stopOnStable]
		]
145 146 147 148 149 150 151
runTasksWithOptions :: ([String] EngineOptions -> (!Maybe EngineOptions,![String])) a !*World -> *World | Runnable a
runTasksWithOptions initFun runnable world
	# (cli,world)			= getCommandLine world
	# (options,world)       = defaultEngineOptions world
	# (mbOptions,msg)       = initFun cli options
	# world                 = show msg world
	| mbOptions =: Nothing  = world
152 153
	# (Just options)		= mbOptions
 	# iworld				= createIWorld options world
154 155
 	# (res,iworld) 			= initJSCompilerState iworld
 	| res =:(Error _) 		= show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
156 157

	# iworld				= serve startupTasks [] systemTasks (timeout options.timeout) iworld
158
	= destroyIWorld iworld
Mart Lubbers's avatar
Mart Lubbers committed
159
where
160
	startupTasks = [t \\ StartupTask t <- toRunnable runnable]
Mart Lubbers's avatar
Mart Lubbers committed
161 162 163 164
	systemTasks =
 		[BackgroundTask updateClock
		,BackgroundTask (processEvents MAX_EVENTS)
		,BackgroundTask stopOnStable]
165

166 167 168 169 170
runTasks :: a !*World -> *World | Runnable a
runTasks tasks world = runTasksWithOptions (\c o -> (Just o,[])) tasks world



171 172 173 174 175 176
show :: ![String] !*World -> *World
show lines world
	# (console,world)	= stdio world
	# console			= seqSt (\s c -> fwrites (s +++ "\n") c) lines console
	# (_,world)			= fclose console world
	= world
177

178
// The iTasks engine consist of a set of HTTP WebService 
179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
engineWebService :: [WebTask] -> [WebService (Map InstanceNo TaskOutput) (Map InstanceNo TaskOutput)] 
engineWebService webtasks =
	[taskUIService webtasks
	,documentService
	,sdsService
	,staticResourceService [url \\ {WebTask|url} <- webtasks]
	]

atRequest :: String (HTTPRequest -> Task a) -> StartableTask | iTask a
atRequest url task = WebTask {WebTask|url = url, task = WebTaskWrapper task}

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

class Runnable a
194
where
195
	toRunnable :: !a -> [StartableTask] 
196

197 198 199
instance Runnable (Task a) | iTask a
where
	toRunnable task = [StartupTask {StartupTask|attributes='DM'.newMap,task=TaskWrapper task}]
200

201
instance Runnable [StartableTask]
202
where
203
	toRunnable list = list
204

205
class Startable a
Bas Lijnse's avatar
Bas Lijnse committed
206
where
207 208 209
	toStartable :: !a -> [StartableTask]

instance Startable (Task a) | iTask a //Default as web task
210
where
211
	toStartable task = [atRequest "/" (const task)]
212

213
instance Startable (HTTPRequest -> Task a) | iTask a //As web task
214
where
215
	toStartable task = [atRequest "/" task]
216

217
instance Startable StartableTask
218
where
219
	toStartable task = [task]
220

221
instance Startable [StartableTask]
222
where
223
	toStartable list = list
224

ecrombag's avatar
ecrombag committed
225
// Determines the server executables path
226
determineAppPath :: !*World -> (!FilePath, !*World)
ecrombag's avatar
ecrombag committed
227
determineAppPath world
228 229
	# ([arg:_],world) = getCommandLine world 
	| dropDirectory arg <> "ConsoleClient.exe"	= toCanonicalPath arg world
230 231 232 233 234 235 236 237 238 239 240 241 242
	//Using dynamic linker:	
	# (res, world)				= getCurrentDirectory world	
	| isError res				= abort "Cannot get current directory."	
	# currentDirectory			= fromOk res
	# (res, world)				= readDirectory currentDirectory world	
	| isError res				= abort "Cannot read current directory."	
	# batchfiles				= [f \\ f <- fromOk res | takeExtension f == "bat" ]
	| 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		
		cmpFileTime (_,Ok {FileInfo | lastModifiedTime = x})
243
					(_,Ok {FileInfo | lastModifiedTime = y}) = timeGm x > timeGm y
244 245 246 247 248 249 250 251 252 253

//By default, we use the modification time of the applaction executable as version id
determineAppVersion :: !FilePath!*World -> (!String,!*World)	
determineAppVersion appPath world
	# (res,world)       = getFileInfo appPath world
	| res =: (Error _)  = ("unknown",world) 
	# tm				= (fromOk res).lastModifiedTime
	# version           = strfTime "%Y%m%d-%H%M%S" tm
	= (version,world)