Engine.icl 9.65 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 37
import iTasks.Internal.EngineTasks

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

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

44
derive class iTask EngineOptions
45

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

49
doTasksWithOptions :: ([String] EngineOptions -> MaybeError [String] EngineOptions) a !*World -> *World | Startable a
50
doTasksWithOptions initFun startable world
51 52
	# (cli,world)			= getCommandLine world
	# (options,world)       = defaultEngineOptions world
53 54 55
	# mbOptions             = initFun cli options
	| mbOptions =:(Error _) = show (fromError mbOptions) world
	# options               = fromOk mbOptions
56 57 58 59 60 61
	# 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
62
where
63 64 65 66 67 68 69 70 71 72
    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
73 74 75
	engineTasks =
 		[BackgroundTask updateClock
		,BackgroundTask (processEvents MAX_EVENTS)
76
		:if (webTasks =: [])
77
			[BackgroundTask stopOnStable]
78 79 80 81
			[BackgroundTask removeOutdatedSessions
		 	,BackgroundTask flushWritesWhenIdle
			]
		]
82

83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136
	// The iTasks engine consist of a set of HTTP Web services
	engineWebService :: [WebTask] -> [WebService (Map InstanceNo TaskOutput) (Map InstanceNo TaskOutput)] 
	engineWebService webtasks =
		[taskUIService webtasks
		,documentService
		,sdsService
		,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

defaultEngineCLIOptions :: [String] EngineOptions -> MaybeError [String] EngineOptions 
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")
			("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)
		]
137

138 139
onRequest :: String (HTTPRequest -> Task a) -> StartableTask | iTask a
onRequest path task = WebTask {WebTask|path = path, task = WebTaskWrapper task}
140

141 142
onStartup :: TaskAttributes (Task a) -> StartableTask | iTask a
onStartup attributes task = StartupTask {StartupTask|attributes = attributes, task = TaskWrapper task}
143 144

class Startable a
Bas Lijnse's avatar
Bas Lijnse committed
145
where
146 147 148
	toStartable :: !a -> [StartableTask]

instance Startable (Task a) | iTask a //Default as web task
149
where
150 151 152 153
	toStartable task =
		[onStartup defaultValue viewWebServerInstructions
		,onRequest "/" (const task)
		]
154

155
instance Startable (HTTPRequest -> Task a) | iTask a //As web task
156
where
157 158 159 160
	toStartable task =
		[onStartup defaultValue viewWebServerInstructions
		,onRequest "/" task
		]
161

162
instance Startable StartableTask
163
where
164
	toStartable task = [task]
165

166
instance Startable [StartableTask]
167
where
168
	toStartable list = list
169

170 171 172 173
instance Startable (a,b) | Startable a & Startable b
where
	toStartable (x,y) = toStartable x ++ toStartable y

174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210
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 +++ "/")
				])

defaultEngineOptions :: !*World -> (!EngineOptions,!*World)
defaultEngineOptions world
	# (appPath,world)    = determineAppPath world	
	# (appVersion,world) = determineAppVersion appPath world
	# appDir             = takeDirectory appPath
	# appName            = (dropExtension o dropDirectory) appPath
	# options =	
		{ appName			= appName
		, appPath			= appPath
        , appVersion        = appVersion
		, serverPort		= IF_POSIX_OR_WINDOWS 8080 80
        , serverUrl         = "http://localhost/"
		, 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
		, timeout			= Just 500
		, 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
211
// Determines the server executables path
212
determineAppPath :: !*World -> (!FilePath, !*World)
ecrombag's avatar
ecrombag committed
213
determineAppPath world
214 215
	# ([arg:_],world) = getCommandLine world 
	| dropDirectory arg <> "ConsoleClient.exe"	= toCanonicalPath arg world
216 217 218 219 220 221 222 223 224 225 226 227 228
	//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})
229
					(_,Ok {FileInfo | lastModifiedTime = y}) = timeGm x > timeGm y
230 231 232 233 234 235 236 237 238 239

//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)