We planned to upgrade GitLab and Mattermost to the latest version this Friday morning (early). You may experience some downtime!

Engine.icl 9.77 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
startEngine :: a !*World -> *World | Publishable a
109 110 111 112 113 114 115 116 117 118 119 120 121 122
startEngine publishable world = startEngineWithOptions defaultEngineCLIOptions publishable world

startEngineWithOptions :: ([String] EngineOptions -> (!Maybe EngineOptions,![String])) a !*World -> *World | Publishable a
startEngineWithOptions initFun publishable world
	# (cli,world)			= getCommandLine world
	# (options,world)       = defaultEngineOptions world
	# (mbOptions,msg)       = initFun cli options
	# world                 = show msg world
	= case mbOptions of
		Nothing = world
		Just options
 			# iworld				= createIWorld (fromJust mbOptions) world
 			# (res,iworld) 			= initJSCompilerState iworld
		 	| res =:(Error _) 		= show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
Mart Lubbers's avatar
Mart Lubbers committed
123
			# iworld				= serve [] (tcpTasks options.serverPort options.keepaliveTime) engineTasks (timeout options.timeout) iworld
124
			= destroyIWorld iworld
125
where
126
	tcpTasks serverPort keepaliveTime = [(serverPort,httpServer serverPort keepaliveTime (engineWebService publishable) taskOutput)]
Mart Lubbers's avatar
Mart Lubbers committed
127 128 129 130 131
	engineTasks =
 		[BackgroundTask updateClock
		,BackgroundTask (processEvents MAX_EVENTS)
		,BackgroundTask removeOutdatedSessions
		,BackgroundTask flushWritesWhenIdle]
132

133
runTasks :: a !*World -> *World | Runnable a
134 135 136 137 138 139 140 141 142
runTasks tasks world = runTasksWithOptions (\c o -> (Just o,[])) tasks world

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
143 144
	# (Just options)		= mbOptions
 	# iworld				= createIWorld options world
145 146
 	# (res,iworld) 			= initJSCompilerState iworld
 	| res =:(Error _) 		= show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
Mart Lubbers's avatar
Mart Lubbers committed
147
	# iworld				= serve (toRunnable runnable) [] systemTasks (timeout options.timeout) iworld
148
	= destroyIWorld iworld
Mart Lubbers's avatar
Mart Lubbers committed
149 150 151 152 153
where
	systemTasks =
 		[BackgroundTask updateClock
		,BackgroundTask (processEvents MAX_EVENTS)
		,BackgroundTask stopOnStable]
154

155 156 157 158 159 160
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
161

162
// The iTasks engine consist of a set of HTTP WebService 
163
engineWebService :: publish -> [WebService (Map InstanceNo TaskOutput) (Map InstanceNo TaskOutput)] | Publishable publish
164
engineWebService publishable = [taskUIService published, documentService, sdsService, staticResourceService [url \\ {PublishedTask|url} <- published]]
165
where
166
	published = publishAll publishable 
167

168
publish :: String (HTTPRequest -> Task a) -> PublishedTask | iTask a
Bas Lijnse's avatar
Bas Lijnse committed
169
publish url task = {url = url, task = WebTaskWrapper task}
170 171 172

instance Publishable (Task a) | iTask a
where
173
	publishAll task = [publish "/" (const task)]
174

Bas Lijnse's avatar
Bas Lijnse committed
175 176
instance Publishable (HTTPRequest -> Task a) | iTask a
where
177
	publishAll task = [publish "/" task]
Bas Lijnse's avatar
Bas Lijnse committed
178
	
179 180 181 182
instance Publishable [PublishedTask]
where
	publishAll list = list

183 184 185 186 187 188 189 190 191 192 193 194
class Runnable a
where
	toRunnable :: !a -> [TaskWrapper] 

instance Runnable (Task a) | iTask a
where
	toRunnable task = [TaskWrapper task]

instance Runnable [TaskWrapper]
where
	toRunnable list = list

ecrombag's avatar
ecrombag committed
195
// Determines the server executables path
196
determineAppPath :: !*World -> (!FilePath, !*World)
ecrombag's avatar
ecrombag committed
197
determineAppPath world
198 199
	# ([arg:_],world) = getCommandLine world 
	| dropDirectory arg <> "ConsoleClient.exe"	= toCanonicalPath arg world
200 201 202 203 204 205 206 207 208 209 210 211 212
	//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})
213
					(_,Ok {FileInfo | lastModifiedTime = y}) = timeGm x > timeGm y
214 215 216 217 218 219 220 221 222 223

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