Engine.icl 17.7 KB
Newer Older
1
implementation module iTasks._Framework.Engine
2

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

15
CLEAN_HOME_VAR	:== "CLEAN_HOME"
16
SESSION_TIMEOUT :== fromString "0000-00-00 00:10:00"
17
MAX_EVENTS 		:== 5
18

19 20 21 22 23
//The following modules are excluded by the SAPL -> Javascript compiler
//because they contain functions implemented in ABC code that cannot
//be compiled to javascript anyway. Handwritten Javascript overrides need
//to be provided for them.
JS_COMPILER_EXCLUDES :==
24
	["iTasks._Framework.Client.Override"
25 26 27 28 29 30 31 32 33 34 35
	,"dynamic_string"
	,"graph_to_string_with_descriptors"
	,"graph_to_sapl_string"
	,"Text.Encodings.Base64"
	,"Sapl.LazyLinker"
	,"Sapl.Target.JS.CodeGeneratorJS"
	,"System.Pointer"
	,"System.File"
	,"System.Directory"
	]

36
import StdInt, StdChar, StdString
37 38
import tcp
import Internet.HTTP, System.Time, System.CommandLine, Data.Func
39

40 41 42
import iTasks._Framework.Engine, iTasks._Framework.IWorld, iTasks._Framework.TaskEval, iTasks._Framework.TaskStore
import iTasks._Framework.Util
import iTasks._Framework.TaskServer
43

44 45 46
from Data.Set import :: Set, newSet
from Sapl.Linker.LazyLinker import generateLoaderState, :: LoaderStateExt
from Sapl.Linker.SaplLinkerShared import :: SkipSet
47
from Sapl.Target.Flavour import :: Flavour, toFlavour
48

49 50 51 52 53 54 55
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

56 57 58 59
startEngine :: a !*World -> *World | Publishable a
startEngine publishable world
	# (opts,world)			= getCommandLine world
	# (app,world)			= determineAppName world
60
	# (appPath,world)		= determineAppPath world	
61 62 63
	# (mbSDKPath,world)		= determineSDKPath SEARCH_PATHS world
	// Show server name
	# world					= show (infoline app) world
64
  	//Check options
65 66 67 68
	# port 					= fromMaybe DEFAULT_PORT (intOpt "-port" opts)
	# keepalive				= fromMaybe DEFAULT_KEEPALIVE_TIME (intOpt "-keepalive" opts)
	# help					= boolOpt "-help" opts
	# sdkOpt				= stringOpt "-sdk" opts
69 70 71 72
	# webDirsOpt		    = stringOpt "-webpublic" opts
	# webDirPaths 			= fmap (split ":") webDirsOpt
	# storeOpt		    	= stringOpt "-store" opts
	# saplOpt		    	= stringOpt "-sapl" opts
73 74 75 76
	//If -help option is given show help and stop
	| help					= show instructions world
	//Check sdkpath
	# mbSDKPath				= maybe mbSDKPath Just sdkOpt //Commandline SDK option overrides found paths
77 78 79 80 81 82 83 84 85 86 87
	# options				=
		{ appName			= app
		, appPath			= appPath
		, sdkPath 			= mbSDKPath
		, serverPort		= port
		, keepalive 		= keepalive
		, webDirPaths 		= webDirPaths
		, storeOpt			= storeOpt
		, saplOpt 			= saplOpt
		}
	= startEngineWithOptions publishable options world
88 89 90 91
where
	instructions :: [String]
	instructions =
		["Available commandline options:"
92
		," -help             : Show this message and exit"
93 94 95 96
		," -sdk <path>       : Use <path> as location of the iTasks SDK (optional)"
		," -webpublic <path> : Use <path> to point to the folders that contain the application's static web content"
	    ," -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"
97 98 99 100
		," -port <port>      : Set port number (default " +++ toString DEFAULT_PORT +++ ")"
		," -keepalive <time> : Set connection keepalive time in seconds (default " +++ toString DEFAULT_KEEPALIVE_TIME +++ ")"
		,""
		]
101

102 103 104
	infoline :: !String -> [String]
	infoline app	= ["*** " +++ app +++ " HTTP server ***",""]

105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
	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]
123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139

startEngineWithOptions :: a ServerOptions !*World -> *World | Publishable a
startEngineWithOptions publishable options world
	# port					= options.serverPort
	# world					= show (running port) world
	# iworld				= initIWorld options world
    //Reset connectedTo for all task instances
    # iworld                = clearConnections iworld
	// mark all instance as outdated initially
    # iworld                = queueAllPersistent iworld
    //Start task server
	# iworld				= serve port (httpServer port options.keepalive (engine publishable) taskInstanceUIs) [BackgroundTask removeOutdatedSessions,BackgroundTask updateClocks, BackgroundTask (processEvents MAX_EVENTS)] timeout iworld
	= finalizeIWorld iworld
where
	running :: !Int -> [String]
	running port = ["Running at http://localhost" +++ (if (port == 80) "/" (":" +++ toString port +++ "/"))]
						
140
	timeout :: !*IWorld -> (!Maybe Timeout,!*IWorld)
141
	timeout iworld = case 'SDS'.read taskEvents iworld of //Check if there are events in the queue
142
		(Ok (Queue [] []),iworld)   = (Just 10,iworld) //Empty queue, don't waste CPU, but refresh
143 144
		(Ok _,iworld)               = (Just 0,iworld)   //There are still events, don't wait
		(Error _,iworld)            = (Just 500,iworld) //Keep retrying, but not too fast
145

146 147 148 149 150 151
    //Read the content of the master instance index on disk to the "ti" field in the iworld
    clearConnections :: !*IWorld -> *IWorld
    clearConnections iworld = snd (modify clear (sdsFocus filter filteredInstanceIndex) iworld)
    where
        //When the server starts we make sure all have a blank connectedTo field
        filter = {InstanceFilter|defaultValue & includeProgress = True}
152
        clear index = ((),[(n,c,Just {InstanceProgress|p & connectedTo = Nothing},a) \\(n,c,Just p,a) <-index])
153 154 155

queueAllPersistent :: !*IWorld -> *IWorld
queueAllPersistent iworld
156
    # (mbIndex,iworld) = read (sdsFocus {InstanceFilter|defaultValue & onlySession=Just False} filteredInstanceIndex) iworld
157
    = case mbIndex of
158
        Ok index    = queueRefresh [(instanceNo,"Persistent first refresh") \\ (instanceNo,_,_,_)<- index]  iworld
159
        _           = iworld
160

161
removeOutdatedSessions :: !*IWorld -> *IWorld
162
removeOutdatedSessions iworld
163
    # (mbIndex,iworld) = read (sdsFocus {InstanceFilter|defaultValue & onlySession=Just True,includeProgress=True} filteredInstanceIndex) iworld
164 165 166
    = case mbIndex of
        Ok index    = foldr removeIfOutdated iworld index
        _           = iworld
167
where
168 169 170
    removeIfOutdated (instanceNo,_,Just {InstanceProgress|connectedTo,lastIO},_) iworld=:{clocks={localDate,localTime}}
        | connectedTo=:Nothing && maybe True (\t -> ((DateTime localDate localTime) - t) > SESSION_TIMEOUT) lastIO
            = deleteTaskInstance instanceNo iworld
171 172 173 174 175
        | otherwise
            = iworld

//HACK FOR RUNNING BACKGROUND TASKS ON A CLIENT
background :: !*IWorld -> *IWorld
176
background iworld = (processEvents MAX_EVENTS o removeOutdatedSessions) iworld
177

178
// The iTasks engine consist of a set of HTTP request handlers
179 180
engine :: publish -> [(!String -> Bool
					  ,!Bool
181 182 183
					  ,!(HTTPRequest (Map InstanceNo TIUIState) *IWorld -> (!HTTPResponse,!Maybe ConnectionType, !Maybe (Map InstanceNo TIUIState), !*IWorld))
					  ,!(HTTPRequest (Map InstanceNo TIUIState) (Maybe {#Char}) ConnectionType *IWorld -> (![{#Char}], !Bool, !ConnectionType, !Maybe (Map InstanceNo TIUIState), !*IWorld))
					  ,!(HTTPRequest (Map InstanceNo TIUIState) ConnectionType *IWorld -> (!Maybe (Map InstanceNo TIUIState), !*IWorld))
184
					  )] | Publishable publish
185 186
engine publishable
	= taskHandlers (publishAll publishable) ++ defaultHandlers
187
where
188
	taskHandlers published
189
		= [let (matchF,reqF,dataF,disconnectF) = webService url task defaultFormat in (matchF,True,reqF,dataF,disconnectF)
190
		  \\ {url,task=TaskWrapper task,defaultFormat} <- published]	
191
	
192
	defaultHandlers = [sdsService, simpleHTTPResponse (const True, handleStaticResourceRequest)]
193

194 195 196 197
initIWorld :: ServerOptions !*World -> *IWorld
initIWorld options world
	# appName 					= options.appName
	# appPath 					= options.appPath
198
	# appDir					= takeDirectory appPath
199
	# dataDir					= case options.storeOpt of
200 201
		Just path 				= path	
		Nothing 				= appDir </> appName +++ "-data"
202
	# (webdirPaths,world) 	 	= case options.webDirPaths of
203 204 205
		Just paths 				= (paths,world)
		Nothing 
			# appWebDirs = [appDir </> "WebPublic"]
206
			= case options.sdkPath of 
207 208 209 210 211 212
				Just sdkDir	//Scan extensions for public web files
					# (libWebDirs,world) = determineWebPublicDirs (sdkDir </>"Server"</>"iTasks"</>"API"</>"Extensions") world
					= ([sdkDir</>"Client"] ++ appWebDirs ++ libWebDirs,world)	
				Nothing
					= (appWebDirs,world)
    # (customCSS,world)    = checkCustomCSS appName webdirPaths world 
213
	# saplPath = case options.saplOpt of
214 215
		Just path 	= path
		Nothing 	= appDir</>"sapl"
216
	# flavourPath = case options.sdkPath of
217
		Just sdkPath 	= sdkPath </> "Dependencies" </> "clean-sapl" </> "src" </>"clean.f"
218
		Nothing 		= saplPath </> "clean.f"
219 220 221
	# (res,world)				= getFileInfo appPath world
	| isError res				= abort "Cannot get executable info."
	# tm						= (fromOk res).lastModifiedTime
222
	# build						= strfTime "%Y%m%d-%H%M%S" tm
223 224
	# (DateTime localDate localTime,world)	= currentLocalDateTimeWorld world
	# (DateTime utcDate utcTime,world)	    = currentUTCDateTimeWorld world
225
	# (_,world)					= ensureDir "data" dataDir world
226
	# tmpDir					= dataDir </> "tmp"
227
	# (_,world)					= ensureDir "tmp" tmpDir world
228 229
	# storeDir					= dataDir </> "stores"
	# (exists,world)			= ensureDir "stores" storeDir world
230 231
	# ((lst, ftmap, _), world)  = generateLoaderState [saplPath] [] JS_COMPILER_EXCLUDES world
	# (flavour, world)			= readFlavour flavourPath world
232
	# (Timestamp seed, world)	= time world
233
	= {IWorld
234 235 236 237 238
	  |server =
        {serverName = appName
	    ,serverURL	= "//127.0.0.1:80"
	    ,buildID	= build
        ,paths      =
239 240
            {appDirectory		    = appDir
	        ,dataDirectory		    = dataDir
241
            ,publicWebDirectories   = webdirPaths 
242
            }
243
        ,customCSS  = customCSS 
244
        }
245
	  ,config				= initialConfig
246 247 248 249 250 251 252
      ,clocks =
        {SystemClocks
        |localDate=localDate
        ,localTime=localTime
        ,utcDate=utcDate
        ,utcTime=utcTime
        }
253 254
      ,current =
	    {TaskEvalState
255
        |taskTime				= 0
256 257 258 259
	    ,taskInstance		    = 0
        ,sessionInstance        = Nothing
        ,attachmentChain        = []
	    ,nextTaskNo			    = 0
260 261
        ,eventRoute			    = 'DM'.newMap
        ,editletDiffs           = 'DM'.newMap
262
        }
263
      ,sdsNotifyRequests    = []
264 265 266 267
      ,memoryShares         = 'DM'.newMap
      ,cachedShares         = 'DM'.newMap
	  ,exposedShares		= 'DM'.newMap
	  ,jsCompilerState		= (lst, ftmap, flavour, Nothing, 'DM'.newMap)
268
	  ,shutdown				= False
269
      ,ioTasks              = {done = [], todo = []}
270
      ,ioStates             = 'DM'.newMap
271
	  ,world				= world
272
      ,resources            = Nothing
Bas Lijnse's avatar
Bas Lijnse committed
273
      ,random               = genRandInt seed
274
      ,onClient				= False
275
	  }
276
where
277 278
	initialConfig :: Config
	initialConfig =
279
		{ sessionTime		= 3600
280 281 282
		, smtpServer		= "localhost"
		}
		
283 284 285 286 287 288 289 290
	ensureDir :: !String !FilePath *World -> (!Bool,!*World)
	ensureDir name path world
		# (exists, world) = fileExists path world
		| exists = (True,world)
		# (res, world) = createDirectory path world
		| isError res = abort ("Cannot create " +++ name +++ " directory" +++ path +++ " : "  +++ snd (fromError res))
		= (False,world)

291
    readFlavour :: !String !*World -> *(!Flavour, !*World)
292 293
    readFlavour flavourPath world
	    # (flavres, world) 	= readFile flavourPath world
294
	    | isError flavres
295
		    = abort ("JavaScript Flavour file cannot be found at " +++ flavourPath)
296 297 298 299 300
	    # mbFlav 			= toFlavour (fromOk flavres)
	    | isNothing mbFlav
		    = abort "Error in JavaScript flavour file"	
	    = (fromJust mbFlav, world)

301 302 303 304 305 306
finalizeIWorld :: !*IWorld -> *World
finalizeIWorld iworld=:{IWorld|world} = world

// Request handler which serves static resources from the application directory,
// or a system wide default directory if it is not found locally.
// This request handler is used for serving system wide javascript, css, images, etc...
307

308
handleStaticResourceRequest :: !HTTPRequest *IWorld -> (!HTTPResponse,!*IWorld)
309
handleStaticResourceRequest req iworld=:{IWorld|server={paths={publicWebDirectories}}}
310
    = serveStaticResource req publicWebDirectories iworld
311
where
312 313 314
    serveStaticResource req [] iworld
	    = (notFoundResponse req,iworld)
    serveStaticResource req [d:ds] iworld=:{IWorld|world}
315
	    # filename		= d +++ filePath req.HTTPRequest.req_path
316 317
	    # type			= mimeType filename
	    # (mbContent, world)	= readFile filename world
318
	    | isOk mbContent		= ({ okResponse &
319 320 321
	    							 rsp_headers = [("Content-Type", type),
												    ("Content-Length", toString (size (fromOk mbContent)))]
							   	   , rsp_data = fromOk mbContent}, {IWorld|iworld & world = world})
322 323 324
        | otherwise
            = serveStaticResource req ds {IWorld|iworld & world = world}

325 326 327 328
	//Translate a URL path to a filesystem path
	filePath path	= ((replaceSubString "/" {pathSeparator}) o (replaceSubString ".." "")) path
	mimeType path	= extensionToMimeType (takeExtension path)

329 330 331
simpleHTTPResponse ::
	(!(String -> Bool),HTTPRequest *IWorld -> (!HTTPResponse,*IWorld))
	->
332 333 334
	(!(String -> Bool),!Bool,!(HTTPRequest (Map InstanceNo TIUIState) *IWorld -> (HTTPResponse, Maybe loc, Maybe (Map InstanceNo TIUIState) ,*IWorld))
							,!(HTTPRequest (Map InstanceNo TIUIState) (Maybe {#Char}) loc *IWorld -> (![{#Char}], !Bool, loc, Maybe (Map InstanceNo TIUIState) ,!*IWorld))
							,!(HTTPRequest (Map InstanceNo TIUIState) loc *IWorld -> (!Maybe (Map InstanceNo TIUIState),!*IWorld)))
335 336
simpleHTTPResponse (pred,responseFun) = (pred,True,initFun,dataFun,lostFun)
where
337
	initFun req _ env
338
		# (rsp,env) = responseFun req env
339
		= (rsp,Nothing,Nothing,env)
340
		
341 342
	dataFun _ _ _ s env = ([],True,s,Nothing,env)
	lostFun _ _ s env = (Nothing,env)
343 344


Bas Lijnse's avatar
Bas Lijnse committed
345
publish :: String ServiceFormat (HTTPRequest -> Task a) -> PublishedTask | iTask a
Bas Lijnse's avatar
 
Bas Lijnse committed
346
publish url format task = {url = url, task = TaskWrapper task, defaultFormat = format}
347 348 349

instance Publishable (Task a) | iTask a
where
350
	publishAll task = [publish "/" (WebApp []) (\_ -> task)]
351

Bas Lijnse's avatar
Bas Lijnse committed
352 353
instance Publishable (HTTPRequest -> Task a) | iTask a
where
354
	publishAll task = [publish "/" (WebApp []) task]
Bas Lijnse's avatar
Bas Lijnse committed
355
	
356 357 358 359
instance Publishable [PublishedTask]
where
	publishAll list = list

ecrombag's avatar
ecrombag committed
360
// Determines the server executables path
361
determineAppPath :: !*World -> (!FilePath, !*World)
ecrombag's avatar
ecrombag committed
362
determineAppPath world
363 364
	# ([arg:_],world) = getCommandLine world 
	| dropDirectory arg <> "ConsoleClient.exe"	= toCanonicalPath arg world
365 366 367 368 369 370 371 372 373 374 375 376 377 378 379
	//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
	
380 381 382
// Determines the server executables name
determineAppName :: !*World -> (!String,!*World)
determineAppName world 
383 384
	# (appPath, world) = determineAppPath world
	= ((dropExtension o dropDirectory) appPath, world)
385 386

determineSDKPath :: ![FilePath] !*World -> (!Maybe FilePath, !*World)
387 388 389 390 391
determineSDKPath paths world
	//Try environment var first
	# (mbCleanHome,world) = getEnvironmentVariable CLEAN_HOME_VAR world
	= case mbCleanHome of
		Nothing			= searchPaths paths world
392
		Just cleanHome	= searchPaths [cleanHome, cleanHome </> "lib", cleanHome </> "Libraries"] world
393 394 395 396 397 398 399 400 401
where	
	searchPaths [] world = (Nothing, world)
	searchPaths [p:ps] world
		# (mbInfo,world) = getFileInfo path world
		= case mbInfo of
			Ok info	| info.directory	= (Just path,world)
			_							= searchPaths ps world
	where
		path = (p </> "iTasks-SDK")
402 403 404 405 406 407 408 409 410

//Do a recursive scan of a directory for subdirectories with the name "WebPublic"
//Files in these directories are meant to be publicly served by an iTask webserver
determineWebPublicDirs :: !FilePath !*World -> (![FilePath], !*World)
determineWebPublicDirs path world
	# (dir, world)	= readDirectory path world	
    = case dir of
        Ok entries
            = appFst flatten (mapSt (checkEntry path) entries world)
411
        _   = ([],world)
412 413 414 415 416 417 418 419 420 421 422
where
    checkEntry :: !FilePath !String !*World -> (![FilePath], !*World)
    checkEntry dir name world
        # path = dir </> name
        | name == "." || name == ".." = ([],world)
        | name == "WebPublic"   = ([path],world) //Dont' recurse into a found WebPublic dir
        | otherwise
		    # (mbInfo,world) = getFileInfo path world
		    = case mbInfo of
			    Ok info	| info.directory	= determineWebPublicDirs path world //Continue search
                _                           = ([],world)
423 424 425 426 427 428 429 430

checkCustomCSS :: !String ![FilePath] !*World -> (!Bool, !*World)
checkCustomCSS appName [] world = (False,world)
checkCustomCSS appName [d:ds] world 
	# (exists,world) = fileExists (d </> addExtension appName "css") world
	| exists 	= (True,world)
				= checkCustomCSS appName ds world