Engine.icl 10.2 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 26
import iTasks.Internal.EngineTasks

27
from iTasks.Extensions.DateTime import toDate, toTime, instance == Date, instance == Time
28

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

34
from System.OS import IF_POSIX_OR_WINDOWS
35

36 37 38 39 40 41 42 43
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
44
	# options =	
45
		{ appName			= appName
46
		, appPath			= appPath
47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
        , 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
	//If -help option is given show help and stop
63 64 65
	# help					= fromMaybe False (boolOpt "-help" "-no-help" cli)
	| help					= (Nothing, instructions defaults)
	//Check commandline options
66 67
	# options =	
		{ defaults 
68 69 70 71 72
		& serverPort		= fromMaybe defaults.serverPort (intOpt "-port" cli)
		, webDirPath 		= fromMaybe defaults.webDirPath (stringOpt "-webdir" cli)
		, storeDirPath      = fromMaybe defaults.storeDirPath (stringOpt "-storedir" cli)
		, tempDirPath 		= fromMaybe defaults.webDirPath (stringOpt "-tempdir" cli)
		, saplDirPath 	    = fromMaybe defaults.saplDirPath (stringOpt "-sapldir" cli)
73
		}
74
	= (Just options,running options.appName options.serverPort)
75
where
76 77
	instructions :: EngineOptions -> [String]
	instructions {serverPort,webDirPath,storeDirPath,tempDirPath,saplDirPath} =
78
		["Available commandline options:"
79 80 81 82 83 84 85 86 87 88
		," -help            : Show this message and exit"
		," -port <port>     : Listen on TCP port number (default " +++ toString serverPort +++ ")"
		," -webdir <path>   : Use <path> to point to the folder that contain the application's static web content"
		,"                  : (default "+++ webDirPath +++ ")"
	    ," -storedir <path> : Use <path> as data store location"
		,"                  : (default " +++ storeDirPath +++ ")"
	    ," -tempdir <path>  : Use <path> as temporary file location"
		,"                  : (default " +++ tempDirPath +++ ")"
	    ," -sapldir <path>  : Use <path> to point to the folder that contains the sapl version of the application"
		,"                  : (default "+++ saplDirPath +++ ")"
89 90
		,""
		]
91

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

97 98 99 100 101
	boolOpt :: !String !String ![String] -> Maybe Bool
	boolOpt trueKey falseKey opts
		| isMember trueKey opts = Just True
		| isMember falseKey opts = Just False
		                         = Nothing
102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
	
	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]
118

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

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

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

172 173 174 175 176
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
177

178
// The iTasks engine consist of a set of HTTP WebService 
179 180
engineWebService :: publish -> [WebService (Map InstanceNo (Queue UIChange)) (Map InstanceNo (Queue UIChange))] | Publishable publish
engineWebService publishable = [taskUIService published, documentService, sdsService, staticResourceService [url \\ {PublishedTask|url} <- published]]
181
where
182
	published = publishAll publishable 
183

184
publish :: String (HTTPRequest -> Task a) -> PublishedTask | iTask a
185
publish url task = {url = url, task = WebTaskWrapper (withFinalSessionLayout task)}
186 187

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

190
publishWithoutLayout :: String (HTTPRequest -> Task a) -> PublishedTask | iTask a
191
publishWithoutLayout url task = {url = url, task = WebTaskWrapper task}
192 193 194

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

Bas Lijnse's avatar
Bas Lijnse committed
197 198
instance Publishable (HTTPRequest -> Task a) | iTask a
where
199
	publishAll task = [publish "/" task]
Bas Lijnse's avatar
Bas Lijnse committed
200
	
201 202 203 204
instance Publishable [PublishedTask]
where
	publishAll list = list

205 206 207 208 209 210 211 212 213 214 215 216
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
217
// Determines the server executables path
218
determineAppPath :: !*World -> (!FilePath, !*World)
ecrombag's avatar
ecrombag committed
219
determineAppPath world
220 221
	# ([arg:_],world) = getCommandLine world 
	| dropDirectory arg <> "ConsoleClient.exe"	= toCanonicalPath arg world
222 223 224 225 226 227 228 229 230 231 232 233 234 235
	//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
236 237 238 239 240 241 242 243 244 245

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