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

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

15 16
from iTasks.WF.Combinators.Tune import class tune(..), instance tune ApplyLayout, :: ApplyLayout(..)
from iTasks.SDS.Combinators.Common import sdsFocus
17

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

22
import iTasks.Internal.IWorld, iTasks.Internal.TaskEval, iTasks.Internal.TaskStore
23 24
import iTasks.Internal.Util
import iTasks.Internal.TaskServer
25
from iTasks.Extensions.DateTime import toDate, toTime, instance == Date, instance == Time
26

27 28 29
from Data.Set import :: Set, newSet
from Sapl.Linker.LazyLinker import generateLoaderState, :: LoaderStateExt
from Sapl.Linker.SaplLinkerShared import :: SkipSet
30
from Sapl.Target.Flavour import :: Flavour, toFlavour
31

32
from System.OS import IF_POSIX_OR_WINDOWS
33

34 35 36 37 38 39 40 41
MAX_EVENTS 		        :== 5

defaultEngineOptions :: !*World -> (!EngineOptions,!*World)
defaultEngineOptions world
	# (appPath,world)    = determineAppPath world	
	# (appVersion,world) = determineAppVersion appPath world
	# appDir             = takeDirectory appPath
	# appName            = (dropExtension o dropDirectory) appPath
42
	# options =	
43
		{ appName			= appName
44
		, appPath			= appPath
45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
        , appVersion        = appVersion
		, serverPort		= IF_POSIX_OR_WINDOWS 8080 80
        , serverUrl         = "http://localhost/"
		, keepaliveTime     = 300 // 5 minutes
		, sessionTime       = 600 // 10 minutes
		, webDirPath 		= appDir </> appName +++ "-www"
		, storeDirPath      = appDir </> appName +++ "-data" </> "stores"
		, tempDirPath       = appDir </> appName +++ "-data" </> "tmp"
		, saplDirPath 	    = appDir </> appName +++ "-sapl"
        , persistTasks      = False
		}
	= (options,world)


defaultEngineCLIOptions :: [String] EngineOptions -> (!Maybe EngineOptions,![String])
defaultEngineCLIOptions cli defaults
	//Check commandline options
	# port 					= fromMaybe defaults.serverPort (intOpt "-port" cli)
	# keepaliveTime			= fromMaybe defaults.keepaliveTime (intOpt "-keepalive" cli)
	# help					= boolOpt "-help" cli
	# noPersist             = boolOpt "-no-persist" cli
	# webOpt				= stringOpt "-webpublic" cli
	# storeOpt		    	= stringOpt "-store" cli
	# saplOpt		    	= stringOpt "-sapl" cli
	//If -help option is given show help and stop
	| help					= (Nothing, instructions)
	# options =	
		{ defaults 
		& serverPort		= port
		, keepaliveTime 	= keepaliveTime
		, webDirPath 		= fromMaybe defaults.webDirPath webOpt
		, storeDirPath      = fromMaybe defaults.storeDirPath storeOpt
		, saplDirPath 	    = fromMaybe defaults.saplDirPath saplOpt
78
        , persistTasks      = not noPersist
79
		}
80
	= (Just options,running options.appName options.serverPort)
81 82 83 84
where
	instructions :: [String]
	instructions =
		["Available commandline options:"
85
		," -help             : Show this message and exit"
86
		," -webpublic <path> : Use <path> to point to the folder that contain the application's static web content"
87 88
	    ," -store <path> 	 : Use <path> as data store location"
	    ," -sapl <path> 	 : Use <path> to point to the folders that hold the sapl version of the application"
89 90
		," -port <port>      : Set port number (default " +++ toString defaults.serverPort +++ ")"
		," -keepalive <time> : Set connection keepalive time in seconds (default " +++ toString defaults.keepaliveTime +++ ")"
91 92
		,""
		]
93

94 95 96 97 98
	running :: !String !Int -> [String]
	running app port = ["*** " +++ app +++ " HTTP server ***"
                       ,""
                       ,"Running at http://localhost" +++ (if (port == 80) "/" (":" +++ toString port +++ "/"))]

99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
	boolOpt :: !String ![String] -> Bool
	boolOpt key opts = isMember key opts
	
	intOpt :: !String ![String] -> Maybe Int
	intOpt key []	= Nothing
	intOpt key [_]	= Nothing
	intOpt key [n,v:r]
		| n == key && isInteger v	= Just (toInt v)
									= intOpt key [v:r]
	where								
		isInteger v = and (map isDigit (fromString v))

	stringOpt :: !String [String] -> Maybe String
	stringOpt key [] = Nothing
	stringOpt key [_] = Nothing
	stringOpt key [n,v:r]
		| n == key	= Just v
					= stringOpt key [v:r]
117

118
startEngine :: a !*World -> *World | Publishable a
119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
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)
			# iworld				= serve [] (tcpTasks options.serverPort options.keepaliveTime) systemTasks timeout iworld
			= destroyIWorld iworld
135
where
136
	tcpTasks serverPort keepaliveTime = [(serverPort,httpServer serverPort keepaliveTime (engine publishable) allUIChanges)]
137 138 139
	systemTasks =
 		[BackgroundTask updateClocks
		,BackgroundTask (processEvents MAX_EVENTS)
Bas Lijnse's avatar
Bas Lijnse committed
140 141
		,BackgroundTask removeOutdatedSessions
		,BackgroundTask flushWritesWhenIdle]
142

143
runTasks :: a !*World -> *World | Runnable a
144 145 146 147 148 149 150 151 152 153
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
 	# iworld				= createIWorld (fromJust mbOptions) world
154 155
 	# (res,iworld) 			= initJSCompilerState iworld
 	| res =:(Error _) 		= show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
156
	# iworld				= serve (toRunnable runnable) [] systemTasks timeout iworld
157
	= destroyIWorld iworld
158 159 160 161 162
where
	systemTasks =
 		[BackgroundTask updateClocks
		,BackgroundTask (processEvents MAX_EVENTS)
		,BackgroundTask stopOnStable]
163

164 165 166 167 168 169 170
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

171 172 173 174 175
timeout :: !*IWorld -> (!Maybe Timeout,!*IWorld)
timeout iworld = case 'SDS'.read taskEvents iworld of //Check if there are events in the queue
	(Ok (Queue [] []),iworld)   = (Just 10,iworld) //Empty queue, don't waste CPU, but refresh
	(Ok _,iworld)               = (Just 0,iworld)   //There are still events, don't wait
	(Error _,iworld)            = (Just 500,iworld) //Keep retrying, but not too fast
176

177 178 179
updateClocks :: !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
updateClocks iworld=:{IWorld|clocks,world}
    //Determine current date and time
Bas Lijnse's avatar
Bas Lijnse committed
180 181 182 183 184 185 186
	# (timestamp,world) 	= time world
	# (local,world)	= currentLocalDateTimeWorld world
	# localDate = toDate local
	  localTime = toTime local 
	# (utc,world)	= currentUTCDateTimeWorld world
	# utcDate = toDate utc
	  utcTime = toTime utc 
187 188 189 190 191 192 193 194 195 196 197 198 199 200
    # iworld = {iworld & world = world}
    //Write SDS's if necessary
    # (mbe,iworld) = if (localDate == clocks.localDate) (Ok (),iworld) (write localDate iworldLocalDate iworld)
	| mbe =:(Error _) = (mbe,iworld)
    # (mbe,iworld) = if (localTime == clocks.localTime) (Ok (),iworld) (write localTime iworldLocalTime iworld)
	| mbe =:(Error _) = (mbe,iworld)
    # (mbe,iworld) = if (utcDate == clocks.utcDate) (Ok (),iworld) (write utcDate iworldUTCDate iworld)
	| mbe =:(Error _) = (mbe,iworld)
    # (mbe,iworld) = if (utcTime == clocks.utcTime) (Ok (),iworld) (write utcTime iworldUTCTime iworld)
	| mbe =:(Error _) = (mbe,iworld)
    # (mbe,iworld) = if (timestamp == clocks.timestamp) (Ok (),iworld) (write timestamp iworldTimestamp iworld)
	| mbe =:(Error _) = (mbe,iworld)
    = (Ok (),iworld)

201
//When we run the built-in HTTP server we need to do active garbage collection of instances that were created for sessions
202
removeOutdatedSessions :: !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
203
removeOutdatedSessions iworld=:{IWorld|options}
204
    # (mbIndex,iworld) = read (sdsFocus {InstanceFilter|defaultValue & onlySession=Just True} filteredInstanceIndex) iworld
205
    = case mbIndex of
206
        Ok index    = checkAll removeIfOutdated index iworld 
207
        Error e     = (Error e, iworld)
208
where
209 210 211 212 213
	checkAll f [] iworld = (Ok (),iworld)
	checkAll f [x:xs] iworld = case f x iworld of
		(Ok (),iworld) = checkAll f xs iworld
		(Error e,iworld) = (Error e,iworld)

214
    removeIfOutdated (instanceNo,_,_,_) iworld=:{options={appVersion},clocks={timestamp}}
215 216
		# (remove,iworld) = case read (sdsFocus instanceNo taskInstanceIO) iworld of
			//If there is I/O information, we check that age first
217
			(Ok (Just (client,Timestamp tInstance)),iworld) //No IO for too long, clean up
218
				= (Ok ((tNow - tInstance) > options.EngineOptions.sessionTime),iworld)
219 220 221 222
			//If there is no I/O information, get meta-data and check builtId and creation date
			(Ok Nothing,iworld)
				= case read (sdsFocus instanceNo taskInstanceConstants) iworld of
					(Ok {InstanceConstants|build,issuedAt},iworld)
223
						| build <> appVersion = (Ok True,iworld)
224
						# (Timestamp tInstance) = issuedAt
225
						| (tNow - tInstance) > options.EngineOptions.sessionTime = (Ok True,iworld)
226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
						= (Ok False,iworld)
					(Error e,iworld)
						= (Error e,iworld)
			(Error e,iworld) 
				= (Error e,iworld)
		= case remove of
			(Ok True)
				# (e,iworld) = deleteTaskInstance instanceNo iworld
				| e=:(Error _) = (e,iworld)
				# (e,iworld) = 'SDS'.write Nothing (sdsFocus instanceNo taskInstanceIO) iworld
				| e=:(Error _) = (e,iworld)
				= (Ok (),iworld)
			(Ok False)
				= (Ok (), iworld)
			(Error e)
				= (Error e,iworld)
	where
243
		(Timestamp tNow) = timestamp
244

Bas Lijnse's avatar
Bas Lijnse committed
245 246 247 248 249 250 251
//When the event queue is empty, write deferred SDS's
flushWritesWhenIdle:: !*IWorld -> (!MaybeError TaskException (), !*IWorld)
flushWritesWhenIdle iworld = case read taskEvents iworld of
		(Error e,iworld)          = (Error e,iworld)
		(Ok (Queue [] []),iworld) = flushDeferredSDSWrites iworld
		(Ok _,iworld)             = (Ok (),iworld)

252 253 254 255 256 257
//When we don't run the built-in HTTP server we don't want to loop forever so we stop the loop
//once all tasks are stable
stopOnStable :: !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
stopOnStable iworld=:{IWorld|shutdown}
    # (mbIndex,iworld) = read (sdsFocus {InstanceFilter|defaultValue & includeProgress=True} filteredInstanceIndex) iworld
	= case mbIndex of 
258 259 260 261 262
		Ok index 
			# shutdown = case shutdown of
				Nothing = if (allStable index) (Just (if (exceptionOccurred index) 1 0)) Nothing
				_       = shutdown
			= (Ok (), {IWorld|iworld & shutdown = shutdown})
263 264
		Error e  = (Error e, iworld)
where
265 266 267
	allStable instances = all (\v -> v =: Stable || v =: Exception) (values instances) 
	exceptionOccurred instances = any (\v -> v =: Exception) (values instances)
	values instances = [value \\ (_,_,Just {InstanceProgress|value},_) <- instances]
268

269 270
//HACK FOR RUNNING BACKGROUND TASKS ON A CLIENT
background :: !*IWorld -> *IWorld
271 272 273 274
background iworld
	# iworld = snd (processEvents MAX_EVENTS iworld)
	# iworld = snd (removeOutdatedSessions iworld)
	= iworld
275

276
// The iTasks engine consist of a set of HTTP WebService 
277
engine :: publish -> [WebService (Map InstanceNo (Queue UIChange)) (Map InstanceNo (Queue UIChange))] | Publishable publish
278
engine publishable = [taskUIService published, documentService, sdsService, staticResourceService [url \\ {PublishedTask|url} <- published]]
279
where
280
	published = publishAll publishable 
281

282
publish :: String (HTTPRequest -> Task a) -> PublishedTask | iTask a
283
publish url task = {url = url, task = WebTaskWrapper (withFinalSessionLayout task)}
284 285

withFinalSessionLayout :: (HTTPRequest -> Task a) -> (HTTPRequest -> Task a) | iTask a
286
withFinalSessionLayout taskf = \req -> tune (ApplyLayout defaultSessionLayout) (taskf req)
287

288
publishWithoutLayout :: String (HTTPRequest -> Task a) -> PublishedTask | iTask a
289
publishWithoutLayout url task = {url = url, task = WebTaskWrapper task}
290 291 292

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

Bas Lijnse's avatar
Bas Lijnse committed
295 296
instance Publishable (HTTPRequest -> Task a) | iTask a
where
297
	publishAll task = [publish "/" task]
Bas Lijnse's avatar
Bas Lijnse committed
298
	
299 300 301 302
instance Publishable [PublishedTask]
where
	publishAll list = list

303 304 305 306 307 308 309 310 311 312 313 314
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
315
// Determines the server executables path
316
determineAppPath :: !*World -> (!FilePath, !*World)
ecrombag's avatar
ecrombag committed
317
determineAppPath world
318 319
	# ([arg:_],world) = getCommandLine world 
	| dropDirectory arg <> "ConsoleClient.exe"	= toCanonicalPath arg world
320 321 322 323 324 325 326 327 328 329 330 331 332 333
	//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})
					(_,Ok {FileInfo | lastModifiedTime = y}) = mkTime x > mkTime y
334 335 336 337 338 339 340 341 342 343

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