Engine.icl 10.9 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
18 19
from System.OS import IF_POSIX_OR_WINDOWS, OS_NEWLINE

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
	# (cli,world)			= getCommandLine world
	# (options,world)       = defaultEngineOptions world
54 55 56
	# mbOptions             = initFun cli options
	| mbOptions =:(Error _) = show (fromError mbOptions) world
	# options               = fromOk mbOptions
57 58 59
	# iworld				= createIWorld options world
	# (res,iworld) 			= initJSCompilerState iworld
	| res =:(Error _) 		= show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
Haye Böhm's avatar
Haye Böhm committed
60 61
	# (symbolsResult, iworld) = initSymbolsShare options.distributed options.appName iworld
	| 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} = (if distributed [case onStartup (sdsServiceTask sdsPort) of StartupTask t = t;] []) ++ [t \\ StartupTask t <- toStartable startable]
68 69
	hasWebTasks = not (webTasks =: [])

Haye Böhm's avatar
Haye Böhm committed
70 71 72
	initSymbolsShare False _ iworld = (Ok (), iworld)
	initSymbolsShare True appName iworld = case storeSymbols appName iworld of
		(Error (e, s), iworld) = (Error s, iworld)
73
		(Ok noSymbols, iworld) = (Ok (),  {iworld & world = show ["Read number of symbols: " +++ toString noSymbols] iworld.world})
Haye Böhm's avatar
Haye Böhm committed
74

75 76 77 78 79
	//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)]
80

Mart Lubbers's avatar
Mart Lubbers committed
81
	engineTasks =
Haye Böhm's avatar
Haye Böhm committed
82
 		[BackgroundTask (processEvents MAX_EVENTS)
83
		:if (webTasks =: [])
84
			[BackgroundTask stopOnStable]
85 86 87 88
			[BackgroundTask removeOutdatedSessions
		 	,BackgroundTask flushWritesWhenIdle
			]
		]
89

90
	// The iTasks engine consist of a set of HTTP Web services
91
	engineWebService :: [WebTask] -> [WebService (Map InstanceNo TaskOutput) (Map InstanceNo TaskOutput)]
92 93 94 95 96 97 98 99 100 101 102 103 104
	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

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

148 149
onStartup :: (Task a) -> StartableTask | iTask a
onStartup task = StartupTask {StartupTask|attributes = defaultValue, task = TaskWrapper task}
150

151 152 153 154 155 156 157 158
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}
159 160

class Startable a
Bas Lijnse's avatar
Bas Lijnse committed
161
where
162 163 164
	toStartable :: !a -> [StartableTask]

instance Startable (Task a) | iTask a //Default as web task
165
where
166
	toStartable task =
167 168
		[onStartup viewWebServerInstructions
		,onRequest "/" task
169
		]
170

171
instance Startable (HTTPRequest -> Task a) | iTask a //As web task
172
where
173
	toStartable task =
174 175
		[onStartup viewWebServerInstructions
		,onRequestFromRequest "/" task
176
		]
177

178
instance Startable StartableTask
179
where
180
	toStartable task = [task]
181

182
instance Startable [StartableTask]
183
where
184
	toStartable list = list
185

186 187 188 189
instance Startable (a,b) | Startable a & Startable b
where
	toStartable (x,y) = toStartable x ++ toStartable y

190 191 192 193 194 195 196 197 198 199 200 201
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 +++ "/")
				])
202

203 204
defaultEngineOptions :: !*World -> (!EngineOptions,!*World)
defaultEngineOptions world
205
	# (appPath,world)    = determineAppPath world
206 207 208
	# (appVersion,world) = determineAppVersion appPath world
	# appDir             = takeDirectory appPath
	# appName            = (dropExtension o dropDirectory) appPath
209
	# options =
210
		{ appName			= appName
211
		, appPath			= appPath
212
		, appVersion        = appVersion
213 214
		, serverPort		= IF_POSIX_OR_WINDOWS 8080 80
        , serverUrl         = "http://localhost/"
215 216
		, 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
217
        , persistTasks      = False
218
		, autoLayout        = True
219
		, distributed       = False
220
		, sdsPort			= 9090
221
		, timeout			= Just 500
222 223 224 225 226 227 228
		, 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
229
// Determines the server executables path
230
determineAppPath :: !*World -> (!FilePath, !*World)
ecrombag's avatar
ecrombag committed
231
determineAppPath world
232
	# ([arg:_],world) = getCommandLine world
233
	| dropDirectory arg <> "ConsoleClient.exe"	= toCanonicalPath arg world
234 235 236
	//Using dynamic linker:
	# (res, world)				= getCurrentDirectory world
	| isError res				= abort "Cannot get current directory."
237
	# currentDirectory			= fromOk res
238 239
	# (res, world)				= readDirectory currentDirectory world
	| isError res				= abort "Cannot read current directory."
240
	# batchfiles				= [f \\ f <- fromOk res | takeExtension f == "bat" ]
241 242 243 244 245
	| 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
246
		cmpFileTime (_,Ok {FileInfo | lastModifiedTime = x})
247
					(_,Ok {FileInfo | lastModifiedTime = y}) = timeGm x > timeGm y
248

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