Engine.icl 11.2 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 7

import StdInt, StdChar, StdString
8
from StdFunc import o, seqList, ::St, const, id
9 10 11 12

import tcp
import Internet.HTTP, System.GetOpt, Data.Func, Data.Functor

13
from Data.Map import :: Map
14
from Data.Queue import :: Queue(..)
15 16
from Data.Set import :: Set, newSet

17
import qualified Data.Map as DM
Haye Böhm's avatar
Haye Böhm committed
18
from System.OS import IF_POSIX_OR_WINDOWS, OS_NEWLINE, IF_WINDOWS
19

20
import Data.List, Data.Error, Data.Func, Data.Tuple, Math.Random, Text
21
import System.Time, System.CommandLine, System.Environment, System.OSError, System.File, System.FilePath, System.Directory
22

23 24 25
import iTasks.Internal.Util, iTasks.Internal.HtmlUtil
import iTasks.Internal.IWorld, iTasks.Internal.WebService, iTasks.Internal.SDSService
import qualified iTasks.Internal.SDS as SDS
26
import iTasks.UI.Layout, iTasks.UI.Layout.Default
27

28
from iTasks.WF.Tasks.SDS import get
29
from iTasks.WF.Combinators.Tune import class tune(..), instance tune ApplyLayout Task, :: ApplyLayout(..)
30
from iTasks.SDS.Combinators.Common import sdsFocus
31
from iTasks.SDS.Sources.System import applicationOptions
32

33
import iTasks.Internal.IWorld, iTasks.Internal.TaskEval, iTasks.Internal.TaskStore
34 35
import iTasks.Internal.Util
import iTasks.Internal.TaskServer
36
import iTasks.Internal.EngineTasks
37
import iTasks.Internal.Distributed.Symbols
38

39 40
from Sapl.Linker.LazyLinker import generateLoaderState, :: LoaderStateExt
from Sapl.Linker.SaplLinkerShared import :: SkipSet
41
from Sapl.Target.Flavour import :: Flavour, toFlavour
42

Mart Lubbers's avatar
Mart Lubbers committed
43 44
MAX_EVENTS 		        :== 5

45
derive class iTask EngineOptions
46

47 48
doTasks :: a !*World -> *World | Startable a
doTasks startable world = doTasksWithOptions defaultEngineCLIOptions startable world
49

50
doTasksWithOptions :: ([String] EngineOptions -> MaybeError [String] EngineOptions) a !*World -> *World | Startable a
51
doTasksWithOptions initFun startable world
52 53 54 55 56 57 58 59 60
	# (cli,world)                = getCommandLine world
	# (options,world)            = defaultEngineOptions world
	# mbOptions                  = initFun cli options
	| mbOptions =:(Error _)      = show (fromError mbOptions) world
	# options                    = fromOk mbOptions
	# iworld                     = createIWorld options world
	# (res,iworld)               = initJSCompilerState iworld
	| res =:(Error _)            = show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
	# (symbolsResult, iworld)    = initSymbolsShare options.distributed options.appName iworld
Haye Böhm's avatar
Haye Böhm committed
61
	| symbolsResult =: (Error _) = show ["Error reading symbols while required: " +++ fromError symbolsResult] (destroyIWorld iworld)
62
	# iworld                     = serve (startupTasks options) (tcpTasks options.serverPort options.keepaliveTime)
63 64
	                                engineTasks (timeout options.timeout) iworld
	= destroyIWorld iworld
65
where
66
    webTasks = [t \\ WebTask t <- toStartable startable]
67
	startupTasks {distributed, sdsPort}
Mart Lubbers's avatar
cleanup  
Mart Lubbers committed
68
		//If distributed, start sds service task
69
		=  (if distributed [startTask (sdsServiceTask sdsPort)] [])
70
		++ [startTask flushWritesWhenIdle]
71 72 73 74 75
		++ (if hasWebTasks
			//If there are webtasks, we need to clean up sessions
			[startTask removeOutdatedSessions]
			//If there are none, we need to stop when all tasks are stable
			[startTask stopOnStable]
Mart Lubbers's avatar
cleanup  
Mart Lubbers committed
76
		//Start all startup tasks
77
		)++ [t \\ StartupTask t <- toStartable startable]
Mart Lubbers's avatar
cleanup  
Mart Lubbers committed
78

79
	startTask t = {StartupTask|attributes=defaultValue,task=TaskWrapper t}
Mart Lubbers's avatar
cleanup  
Mart Lubbers committed
80

81 82
	hasWebTasks = not (webTasks =: [])

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 89 90 91 92
	//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)]
93

94
	engineTasks = [BackgroundTask (processEvents MAX_EVENTS)]
95

96
	// The iTasks engine consist of a set of HTTP Web services
97
	engineWebService :: [WebTask] -> [WebService (Map InstanceNo TaskOutput) (Map InstanceNo TaskOutput)]
98 99 100 101 102 103 104 105 106 107 108 109 110
	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

111
defaultEngineCLIOptions :: [String] EngineOptions -> MaybeError [String] EngineOptions
112 113 114 115 116 117 118 119 120 121 122 123 124
defaultEngineCLIOptions [argv0:argv] defaults
	# (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])
		Just settings = Ok settings
where
	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")
125
			("Specify the HTTP port (default: " +++ toString defaults.serverPort +++ ")")
126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
		, 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)
148 149
		, Option [] ["distributed"] (NoArg (fmap \o->{o & distributed=True}))
			"Enable distributed mode (populate the symbols share)"
150 151
		, Option ['s'] ["sdsPort"] (ReqArg (\p->fmap \o->{o & sdsPort=toInt p}) "SDSPORT")
			("Specify the SDS port (default: " +++ toString defaults.sdsPort +++ ")")
152
		]
153

154 155
onStartup :: (Task a) -> StartableTask | iTask a
onStartup task = StartupTask {StartupTask|attributes = defaultValue, task = TaskWrapper task}
156

157 158 159 160 161 162 163 164
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}
165 166

class Startable a
Bas Lijnse's avatar
Bas Lijnse committed
167
where
168 169 170
	toStartable :: !a -> [StartableTask]

instance Startable (Task a) | iTask a //Default as web task
171
where
172
	toStartable task =
173 174
		[onStartup viewWebServerInstructions
		,onRequest "/" task
175
		]
176

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

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

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

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

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

209 210
defaultEngineOptions :: !*World -> (!EngineOptions,!*World)
defaultEngineOptions world
211
	# (appPath,world)    = determineAppPath world
212 213 214
	# (appVersion,world) = determineAppVersion appPath world
	# appDir             = takeDirectory appPath
	# appName            = (dropExtension o dropDirectory) appPath
215
	# options =
216
		{ appName			= appName
217
		, appPath			= appPath
218
		, appVersion        = appVersion
219 220
		, serverPort		= IF_POSIX_OR_WINDOWS 8080 80
        , serverUrl         = "http://localhost/"
221 222
		, 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
223
        , persistTasks      = False
224
		, autoLayout        = True
225
		, distributed       = False
226
		, sdsPort			= 9090
227
		, timeout			= Just 500
228 229 230 231 232 233 234
		, webDirPath 		= appDir </> appName +++ "-www"
		, storeDirPath      = appDir </> appName +++ "-data" </> "stores"
		, tempDirPath       = appDir </> appName +++ "-data" </> "tmp"
		, saplDirPath 	    = appDir </> appName +++ "-sapl"
		}
	= (options,world)

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

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