Commit 127a2d41 authored by Bas Lijnse's avatar Bas Lijnse

Centralized itasks engine options in an EngineOptions record that you can...

Centralized itasks engine options in an EngineOptions record that you can customize using startEngineWithOptions
parent 89dd8f56
......@@ -5,7 +5,7 @@ definition module iTasks
*/
import
// iTasks engine
iTasks.Internal.Engine
iTasks.Engine
// iTasks API
, iTasks.SDS.Definition
, iTasks.SDS.Sources.Core
......
definition module iTasks.Internal.Engine
definition module iTasks.Engine
/**
* This module provides the iTasks engine.
* This is the primary function that creates the complete
......@@ -6,37 +6,26 @@ definition module iTasks.Internal.Engine
*/
from StdList import ++, iterate, take
from System.FilePath import </>
from Data.Maybe import :: Maybe
from System.FilePath import :: FilePath
from System.OS import IF_POSIX_OR_WINDOWS
import iTasks.Internal.Task
from Internet.HTTP import :: HTTPRequest
from Internet.HTTP import :: HTTPRequest
import iTasks.WF.Definition
//* Configuration defaults
DEFAULT_PORT :== IF_POSIX_OR_WINDOWS 8080 80
DEFAULT_KEEPALIVE_TIME :== 300 // 5 minutes
SESSION_TIMEOUT :== 600 //Seconds (10 minutes)
MAX_EVENTS :== 5
:: PublishedTask =
{ url :: String
, task :: WebTaskWrapper
}
:: ServerOptions =
:: EngineOptions =
{ appName :: String
, appPath :: FilePath
, appPath :: FilePath // Location of the application's executable
, appVersion :: String
, serverPort :: Int
, keepalive :: Int
, serverUrl :: String
, keepaliveTime :: Int
, sessionTime :: Int
, persistTasks :: Bool
, webDirPath :: Maybe FilePath
, storeDirPath :: Maybe FilePath
, saplDirPath :: Maybe FilePath
, webDirPath :: FilePath // Location of public files that are served by the iTask webserver
, storeDirPath :: FilePath // Location of the application's persistent data files
, tempDirPath :: FilePath // Location for temporary files used in tasks
, saplDirPath :: FilePath // Location of the application's sapl files (client-side code)
}
:: WebTaskWrapper = E.a: WebTaskWrapper (HTTPRequest -> Task a) & iTask a
:: TaskWrapper = E.a: TaskWrapper (Task a) & iTask a
/**
* Starts the task engine with a list of published task definitions.
......@@ -51,11 +40,51 @@ startEngine :: a !*World -> *World | Publishable a
* Starts the task engine with options and a list of published task definitions.
*
* @param Tasks to start
* @param Options to use like port and server paths.
* @param An initialization function to set the engine options with:
@param The command line arguments
@param The default options
@return Maybe the engine options, in case of Nothing, the engine is not started
@return A message that is printed to the console when the engine is started
* @param The world
* @return The world
*/
startEngineWithOptions :: a ServerOptions !*World -> *World | Publishable a
startEngineWithOptions :: ([String] EngineOptions -> (!Maybe EngineOptions,![String])) a !*World -> *World | Publishable a
/**
* The function that takes the 'standard' command line options of an itask engine and
* shows the default help and startup message
*
* Essentially: startEngine = startEngineWithOptions defaultEngineCLIOptions
* @param The command line arguments
* @param The default options
* @return Maybe the engine options, in case of Nothing, the engine is not started
* @return A message that is printed to the console when the engine is started
*/
defaultEngineCLIOptions :: [String] EngineOptions -> (!Maybe EngineOptions,![String])
/**
* Determines the default options for an application
*/
defaultEngineOptions :: !*World -> (!EngineOptions,!*World)
/**
* Start a stripped task engine (without an HTTP server) with a list of tasks to be created
*/
runTasks :: a !*World -> *World | Runnable a
runTasksWithOptions :: ([String] EngineOptions -> (!Maybe EngineOptions,![String])) a !*World -> *World | Runnable a
// === Wrapping interactive tasks for use with the builtin iTask webserver ===
:: PublishedTask =
{ url :: String
, task :: WebTaskWrapper
}
:: WebTaskWrapper = E.a: WebTaskWrapper (HTTPRequest -> Task a) & iTask a
:: TaskWrapper = E.a: TaskWrapper (Task a) & iTask a
/**
* Wraps a task together with a url to make it publishable by the engine
......@@ -76,20 +105,11 @@ instance Publishable (Task a) | iTask a
instance Publishable (HTTPRequest -> Task a) | iTask a
instance Publishable [PublishedTask]
determineAppName :: !*World -> (!String,!*World)
// === Wrapping non-interactive tasks for running on the command line ===
/**
* Start a stripped task engine (without an HTTP server) with a list of tasks to be created
*/
class Runnable a
where
toRunnable :: !a -> [TaskWrapper]
instance Runnable (Task a) | iTask a
instance Runnable [TaskWrapper]
runTasks :: a !*World -> *World | Runnable a
//HACK FOR RUNNING BACKGROUND TASKS ON A CLIENT
background :: !*IWorld -> *IWorld
implementation module iTasks.Extensions.Admin.StoreAdmin
import iTasks
import qualified iTasks.Internal.Store
import qualified iTasks.Internal.Task
import Data.Error
manageStore :: Task ()
......@@ -20,7 +21,7 @@ selectStore
//Low-level access
deleteStore :: (String,String) -> Task ()
deleteStore (namespace,storename) = mkInstantTask eval
deleteStore (namespace,storename) = 'iTasks.Internal.Task'.mkInstantTask eval
where
eval _ iworld = case 'iTasks.Internal.Store'.deleteValue namespace storename iworld of
(Ok (),iworld) = (Ok (),iworld)
......
......@@ -2,7 +2,7 @@ definition module iTasks.Extensions.Admin.TonicAdmin
import iTasks
from iTasks.Internal.Tonic.Images import :: TaskAppRenderer, :: ModelTy, :: ClickMeta, :: TonicImageState, :: ActionState, :: TClickAction
from iTasks.Internal.Tonic.Types import :: AllBlueprints, :: TonicModule, :: TonicFunc, :: FuncName, :: ModuleName, :: NavStack, :: BlueprintIdent
from iTasks.Internal.Tonic.Types import :: AllBlueprints, :: TonicModule, :: TonicFunc, :: FuncName, :: ModuleName, :: NavStack, :: BlueprintIdent, :: ExprId
from Graphics.Scalable import :: TagSource, :: TagRef, :: Image, :: ImageTag
tonicDashboard :: [TaskAppRenderer] -> Task ()
......
......@@ -9,6 +9,7 @@ import iTasks.Internal.Tonic.Types
import iTasks.Internal.Tonic.AbsSyn
import iTasks.Internal.Tonic.Pretty
import iTasks.Internal.Tonic.Images
import iTasks.Internal.Task
import iTasks.UI.Definition
import iTasks.Extensions.DateTime
from StdFunc import seq
......
......@@ -2,6 +2,7 @@ implementation module iTasks.Extensions.Development.Tools
import iTasks
import iTasks.Internal.IWorld, iTasks.Internal.SDS
import System.Environment
import System.OS
CPM_EXE :== IF_POSIX_OR_WINDOWS "bin/cpm" "Tools\\cpm.exe"
......
implementation module iTasks.Extensions.SQLDatabase
import iTasks, Database.SQL, Database.SQL.MySQL, Database.SQL.SQLite, Data.Error, Data.Func, System.FilePath
import iTasks.Internal.IWorld, iTasks.Internal.SDS
import iTasks.Internal.Task, iTasks.Internal.IWorld, iTasks.Internal.SDS
import qualified Data.Map
//Extend Resource type for mysql resources
......@@ -249,8 +249,8 @@ openSQLiteDB :: !SQLDatabase !*IWorld -> (MaybeErrorString (!*SQLiteCursor, !*SQ
openSQLiteDB db iworld=:{IWorld|resources=Just (SQLiteResource con)}
= (Ok con, {IWorld|iworld & resources=Nothing})
openSQLiteDB db iworld=:{IWorld|resources=Nothing}
# iworld=:{IWorld|world,server={paths={dataDirectory}}} = {IWorld|iworld & resources = Nothing}
# db = {db & database = dataDirectory </> db.database}
# iworld=:{IWorld|world,options={storeDirPath}} = {IWorld|iworld & resources = Nothing}
# db = {db & database = storeDirPath </> db.database}
# (err,mbContext,world) = openContext world
| isJust err = (Error (toString (fromJust err)),{IWorld|iworld & world = world})
# (err,mbConn,context) = openConnection db (fromJust mbContext)
......
......@@ -13,7 +13,6 @@ from Data.Set import :: Set, newSet
from iTasks.UI.JS.Interface import :: JSWorld, :: JSEvent, :: JSObj, :: JSObject, :: JSVal
from iTasks.Internal.Client.RunOnClient import createClientIWorld, getUIUpdates
from iTasks.Internal.Engine import background
import iTasks.Internal.IWorld
import Sapl.Target.JS.CodeGeneratorJS, Sapl.Linker.LazyLinker, Sapl.SaplParser
......
......@@ -122,16 +122,18 @@ createClientIWorld serverURL currentInstance
# world = newWorld
# (timestamp=:(Timestamp seed),world) = time world
= {IWorld
|server =
{serverName = "application"
,serverURL = serverURL
,buildID = "build"
,paths = {appDirectory = locundef "appDirectory"
,dataDirectory = locundef "dataDirectory"
,webDirectory = locundef "webDirectory"
,saplDirectory = locundef "saplDirectory"}
}
,config = {sessionTime = 3600, smtpServer = locundef "smtpServer", persistTasks = True}
|options = { appName = "application"
, appPath = locundef "appDirectory"
, appVersion = locundef "appVersion"
, serverPort = 80
, serverUrl = locundef "serverUrl"
, keepaliveTime = locundef "keepaliveTime"
, sessionTime = locundef "sessionTime"
, persistTasks = False
, webDirPath = locundef "webDirectory"
, storeDirPath = locundef "dataDirectory"
, tempDirPath = locundef "tempDirectory"
, saplDirPath = locundef "saplDirectory"}
,clocks =
{ timestamp = timestamp
, localDate = {Date|day = 1, mon = 1, year = 1977}
......
......@@ -10,6 +10,7 @@ from StdFile import class FileSystem
from System.Time import :: Timestamp
from Text.JSON import :: JSONNode
from System.Process import :: ProcessHandle, :: ProcessIO
from iTasks.Engine import :: EngineOptions
from iTasks.UI.Definition import :: UI, :: UINodeType
from iTasks.Internal.TaskState import :: ParallelTaskState, :: TIMeta, :: DeferredJSON
from iTasks.Internal.Task import :: ExternalProcessTask, :: ConnectionTask, :: BackgroundTask
......@@ -29,8 +30,7 @@ from TCPIP import :: TCP_Listener, :: TCP_Listener_, :: TCP_RChannel_, :: TCP_SC
CLEAN_HOME_VAR :== "CLEAN_HOME"
:: *IWorld = { server :: !ServerInfo // Static server info, initialized at startup
, config :: !Config // Server configuration
:: *IWorld = { options :: !EngineOptions // Engine configuration
, clocks :: !SystemClocks // Server side clocks
, current :: !TaskEvalState // Shared state during task evaluation
......@@ -54,26 +54,6 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
, shutdown :: !Maybe Int // Signals the server function to shut down, the int will be set as exit code
}
:: Config =
{ sessionTime :: !Int //* Time (in seconds) before inactive sessions are garbage collected. Default is 3600 (one hour).
, smtpServer :: !String //* The smtp server to use for sending e-mails
, persistTasks :: !Bool //* Persist the task state to disk
}
:: ServerInfo =
{ serverName :: !String // The name of the server application
, serverURL :: !String // URL of the server like "//any.com:80"
, buildID :: !String // The date/time identifier of the server's build
, paths :: !SystemPaths // Filesystem paths that are used by iTasks
}
:: SystemPaths =
{ appDirectory :: !FilePath // Location of the application's executable
, dataDirectory :: !FilePath // Location of the application's data files
, webDirectory :: !FilePath // List of directories that contain files that are served publicly by the iTask webserver
, saplDirectory :: !FilePath // Location of the application's sapl files
}
:: SystemClocks =
{ timestamp :: !Timestamp
, localDate :: !Date
......@@ -139,7 +119,6 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
:: BackgroundTaskId :== Int
:: IOStates :== Map TaskId IOState
:: IOState
= IOActive !(Map ConnectionId (!Dynamic,!Bool)) // Bool: stability
......@@ -156,17 +135,12 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
/**
* Creates and initializes the IWorld state
*
* @param The application's name
* @param The application's path (e.g. to executable).
* @param Persist task administration
* @param The path where static web assets can be found (optional)
* @param The path where the iTasks data store is located (optional)
* @param Path to where the applications's SAPL files are stored (optional)
* @param The engine options
* @param The world
*
* @return An initialized iworld
*/
createIWorld :: !String FilePath !Bool !(Maybe FilePath) !(Maybe FilePath) !(Maybe FilePath) !*World -> *IWorld
createIWorld :: !EngineOptions !*World -> *IWorld
/**
* Initialize the SAPL->JS compiler state
......
......@@ -9,8 +9,8 @@ from Text.JSON import :: JSONNode
from iTasks.WF.Definition import :: TaskId, :: InstanceNo, :: TaskNo
from iTasks.WF.Combinators.Core import :: TaskListItem, :: ParallelTaskType
from iTasks.Extensions.DateTime import :: Time, :: Date, :: DateTime, toTime, toDate
from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.Internal.IWorld import :: Config
from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.Engine import :: EngineOptions(..)
from System.Process import :: ProcessHandle, :: ProcessIO
from StdFile import class FileSystem(..)
......@@ -55,35 +55,13 @@ JS_COMPILER_EXCLUDES :==
,"System.Directory"
]
createIWorld :: !String FilePath !Bool !(Maybe FilePath) !(Maybe FilePath) !(Maybe FilePath) !*World -> *IWorld
createIWorld appName appPath persistTasks mbWebdirPath mbStorePath mbSaplPath world
# appDir = takeDirectory appPath
# dataDir = fromMaybe (appDir </> appName +++ "-data") mbStorePath
# webDir = fromMaybe (appDir </> appName +++ "-www") mbWebdirPath
# saplDir = fromMaybe (appDir </> appName +++ "-sapl") mbSaplPath
# (saplDir,world) = fallBackSaplDir appDir saplDir world
# (res,world) = getFileInfo appPath world
| isError res = abort "Cannot get executable info."
# tm = (fromOk res).lastModifiedTime
# build = strfTime "%Y%m%d-%H%M%S" tm
createIWorld :: !EngineOptions !*World -> *IWorld
createIWorld options world
# (local,world) = currentLocalDateTimeWorld world
# (utc,world) = currentUTCDateTimeWorld world
# tmpDir = dataDir </> "tmp"
# storeDir = dataDir </> "stores"
# (timestamp=:(Timestamp seed), world) = time world
= {IWorld
|server =
{serverName = appName
,serverURL = "//127.0.0.1:80"
,buildID = build
,paths =
{appDirectory = appDir
,dataDirectory = dataDir
,webDirectory = webDir
,saplDirectory = saplDir
}
}
,config = initialConfig persistTasks
|options = options
,clocks =
{SystemClocks
|timestamp=timestamp
......@@ -114,25 +92,10 @@ createIWorld appName appPath persistTasks mbWebdirPath mbStorePath mbSaplPath wo
,random = genRandInt seed
,onClient = False
}
where
initialConfig persistTasks =
{ sessionTime = 3600
, smtpServer = "localhost"
, persistTasks = persistTasks
}
//Temporary fallback to use "sapl" instead of "<Application name>-sapl".
//Once everybody uses an upgraded sapl-collector-linker that creates the proper
//directory name it can be removed
fallBackSaplDir appDir saplDir world
# (exists, world) = fileExists saplDir world
| exists = (saplDir,world)
= (appDir </> "sapl",world)
initJSCompilerState :: *IWorld -> *(!MaybeErrorString (), !*IWorld)
initJSCompilerState iworld=:{IWorld|world,server={paths={appDirectory,saplDirectory}}}
# ((lst, ftmap, _), world) = generateLoaderState [saplDirectory] [] JS_COMPILER_EXCLUDES world
initJSCompilerState iworld=:{IWorld|world,options={EngineOptions|saplDirPath}}
# ((lst, ftmap, _), world) = generateLoaderState [saplDirPath] [] JS_COMPILER_EXCLUDES world
# jsCompilerState = { loaderState = lst, functionMap = ftmap, flavour = cleanFlavour, parserState = Nothing, skipMap = 'DM'.newMap}
= (Ok (), {iworld & jsCompilerState = Just jsCompilerState, world = world})
......
......@@ -3,6 +3,7 @@ implementation module iTasks.Internal.RemoteAccess
import StdString, StdMisc, StdFile, StdBool, StdArray
import Text
import iTasks.Engine
import iTasks.WF.Definition
import iTasks.Internal.Task
import iTasks.Internal.IWorld
......@@ -41,10 +42,10 @@ closeException s
= Error (dynamic e, toString e)
httpRequest_server :: !HTTPMethod !URI !String !*IWorld -> *(!HTTPResponse, !*IWorld)
httpRequest_server method uri request iworld=:{IWorld|current={taskTime},server={buildID,paths={dataDirectory}},world}
# infile = dataDirectory </> "tmp-" +++ buildID </> (mkFileName "request")
# outfile = dataDirectory </> "tmp-" +++ buildID </> (mkFileName "response")
# hfile = dataDirectory </> "tmp-" +++ buildID </> (mkFileName "response-header")
httpRequest_server method uri request iworld=:{IWorld|current={taskTime},options={tempDirPath},world}
# infile = tempDirPath </> (mkFileName "request")
# outfile = tempDirPath </> (mkFileName "response")
# hfile = tempDirPath </> (mkFileName "response-header")
# (res,world) = writeFile infile request world
| isError res
= abort "httpRequest_server: infile creation error"
......
......@@ -6,6 +6,7 @@ from Data.Map import :: Map
import qualified Data.Map as DM
import Data.Error, Data.Func, Data.Tuple, System.Time, Text, Text.JSON
import qualified Data.Set as Set
import iTasks.Engine
import iTasks.Internal.IWorld
import iTasks.Internal.Task, iTasks.Internal.TaskStore, iTasks.Internal.TaskEval
......@@ -423,12 +424,12 @@ newSDSId iworld=:{IWorld|random}
= (toString (take 32 [toChar (97 + abs (i rem 26)) \\ i <- random]) , {IWorld|iworld&random = drop 32 random})
newURL :: !*IWorld -> (!String, !*IWorld)
newURL iworld=:{IWorld|server={serverURL},random}
newURL iworld=:{IWorld|options={serverUrl},random}
# (sdsId, iworld) = newSDSId iworld
= getURLbyId sdsId iworld
// TODO: different URL for clients
getURLbyId :: !String !*IWorld -> (!String, !*IWorld)
getURLbyId sdsId iworld=:{IWorld|server={serverURL},random}
= ("sds:" +++ serverURL +++ "/" +++ sdsId, iworld)
getURLbyId sdsId iworld=:{IWorld|options={serverUrl},random}
= ("sds:" +++ serverUrl +++ "/" +++ sdsId, iworld)
......@@ -10,11 +10,11 @@ import Text, Text.JSON, iTasks.Internal.Serialization
import iTasks.Internal.Client.JSStore
import iTasks.Internal.SDS
from iTasks.Internal.IWorld import :: IWorld {config,onClient,server,memoryShares,world}, :: ServerInfo(..), :: SystemPaths(..), :: Resource
from iTasks.Engine import :: EngineOptions(..)
from iTasks.Internal.IWorld import :: IWorld {options,onClient,memoryShares,world}, :: Resource
from iTasks.Internal.Task import exception
from iTasks.Internal.TaskState import :: DeferredJSON(..)
from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.Internal.IWorld import :: Config(..)
from iTasks.WF.Definition import class iTask
from iTasks.Internal.Generic.Visualization import generic gText, :: TextFormat(..), toMultiLineText
......@@ -46,89 +46,6 @@ memoryStore namespace defaultV = storeShare namespace False InMemory defaultV
jsonFileStore :: !StoreNamespace !Bool !Bool !(Maybe a) -> RWShared StoreName a a | JSONEncode{|*|}, JSONDecode{|*|}, TC a
jsonFileStore namespace check reset defaultV = storeShare namespace True InJSONFile defaultV
blobStoreWrite :: !StoreNamespace !StoreName !{#Char} !*IWorld -> *IWorld //TODO: Propagate error up
blobStoreWrite namespace key blob iworld=:{IWorld|onClient=True}
= jsStoreValue namespace key blob iworld
blobStoreWrite namespace key blob iworld
# (_,iworld) = writeToDisk namespace key blob iworld
= iworld
blobStoreRead :: !StoreNamespace !StoreName !*IWorld -> (!MaybeError StoreReadError {#Char}, !*IWorld)
blobStoreRead namespace key iworld=:{onClient=True}
# (mbBlob,iworld) =jsLoadValue namespace key iworld
= (maybe (Error (StoreReadMissingError (namespace +++ "/" +++ key))) Ok mbBlob, iworld)
blobStoreRead namespace key iworld
= case readFromDisk namespace key iworld of
(Ok (_,content),iworld) = (Ok content,iworld)
(Error e,iworld) = (Error e,iworld)
writeToDisk :: !StoreNamespace !StoreName !String !*IWorld -> (MaybeErrorString (), *IWorld)
writeToDisk namespace key content iworld=:{server={buildID,paths={dataDirectory}},world}
# location = dataDirectory </> "stores"
//Check if the location exists and create it otherwise
# (exists,world) = fileExists location world
# (res,world) = if exists (Ok (),world)
( case createDirectory location world of
(Ok (), world) = (Ok (),world)
(Error e, world) = (Error ("Cannot create store: " +++ location +++ ": " +++ snd e), world)
)
| res =: (Error _)
= (res,{IWorld|iworld & world = world})
//Check if the namespace exists and create it otherwise
# (exists,world) = fileExists (location </> namespace) world
# (res,world) = if exists (Ok (),world)
( case createDirectory (location </> namespace) world of
(Ok (), world) = (Ok (), world)
(Error e, world) = (Error ("Cannot create namespace " +++ namespace +++ ": " +++ snd e), world)
)
| res =: (Error _)
= (res,{IWorld|iworld & world = world})
//Write the value
# filename = addExtension (location </> namespace </> safeName key) "txt"
# (ok,file,world) = fopen filename FWriteData world
| not ok = (Error ("Failed to write value to store: " +++ filename),{IWorld|iworld & world = world})
//Write build ID
# file = fwrites buildID file
//Write content
# file = fwrites content file
# (ok,world) = fclose file world
= (Ok (),{IWorld|iworld & world = world})
readFromDisk :: !StoreNamespace !StoreName !*IWorld -> (MaybeError StoreReadError (!BuildID,!String), !*IWorld)
readFromDisk namespace key iworld=:{server={paths={dataDirectory}},world}
# filename = addExtension (dataDirectory </> "stores" </> namespace </> safeName key) "txt"
# (ok,file,world) = fopen filename FReadData world
| ok
# (maybe_build_id_and_content,file) = read_file storeDesc file
# (ok,world) = fclose file world
| ok
= (maybe_build_id_and_content,{iworld & world = world})
= (Error (StoreReadDataError storeDesc),{iworld & world = world})
| otherwise
= (Error (StoreReadMissingError storeDesc), {iworld & world = world})
where
read_file :: !String !*File -> (!MaybeError StoreReadError (BuildID,String), !*File)
read_file desc file
# (buildId,file) = freads file 15
| size buildId<15
= (Ok (buildId,""),file)
# (ok,file) = fseek file 0 FSeekEnd
| not ok
= (Error (StoreReadDataError desc),file)
# (file_size,file) = fposition file
| file_size<15
= (Error (StoreReadDataError desc),file)
# (ok,file) = fseek file 15 FSeekSet
| not ok
= (Error (StoreReadDataError desc),file)
# content_size = file_size - 15;
# (content,file) = freads file content_size;
| size content<>content_size
= (Error (StoreReadDataError desc),file)
= (Ok (buildId,content),file)
storeDesc = namespace +++ "/" +++ key
deleteValue :: !StoreNamespace !StoreName !*IWorld -> *(MaybeErrorString (),*IWorld)
deleteValue namespace delKey iworld=:{onClient=True}
= (Ok (), jsDeleteValue namespace delKey iworld)
......@@ -141,13 +58,13 @@ deleteValues :: !StoreNamespace !StorePrefix !*IWorld -> *(MaybeErrorString (),*
deleteValues namespace delKey iworld = deleteValues` namespace delKey startsWith startsWith iworld
deleteValues` :: !String !String !(String String -> Bool) !(String String -> Bool) !*IWorld -> *(MaybeErrorString (),*IWorld)
deleteValues` namespace delKey filterFuncCache filterFuncDisk iworld=:{server={buildID,paths={dataDirectory}},world}
deleteValues` namespace delKey filterFuncCache filterFuncDisk iworld=:{options={storeDirPath},world}
//Delete items from disk
# (res,world) = deleteFromDisk world
= (res,{iworld & world = world})
where
deleteFromDisk world
# storeDir = dataDirectory </>"store"</> namespace
# storeDir = storeDirPath</> namespace
# (res, world) = readDirectory storeDir world
= case res of
(Ok _) = deleteFiles storeDir (fromOk res) world
......@@ -184,19 +101,19 @@ where
= copy (i + 1) {n & [i] = '_'}
listStoreNamespaces :: !*IWorld -> (![StoreNamespace], !*IWorld)
listStoreNamespaces iworld=:{server={buildID,paths={dataDirectory}},world}
# (res,world) = readDirectory (dataDirectory</>"stores") world
listStoreNamespaces iworld=:{options={storeDirPath},world}
# (res,world) = readDirectory storeDirPath world
= case res of
Error e = ([], {iworld & world = world})
Ok files = ([f \\ f <- files | not (f == "." || f == "..")], {iworld & world = world})
listStoreNames :: !StoreNamespace !*IWorld -> (!MaybeErrorString [StoreName], !*IWorld)
listStoreNames namespace iworld
# (namespaces,iworld=:{server={buildID,paths={dataDirectory}},world})
# (namespaces,iworld=:{options={storeDirPath},world})
= listStoreNamespaces iworld
| not (isMember namespace namespaces)
= (Error ("Namespace " +++ namespace +++ " does not exist"), {iworld & world = world})
# storeDir = dataDirectory </>"stores"</> namespace
# storeDir = storeDirPath </> namespace
# (res,world) = readDirectory storeDir world
= case res of
Error e = (Error (snd e), {iworld & world = world})
......
......@@ -6,12 +6,12 @@ from TCPIP import class ChannelEnv, :: IPAddress, :: Timeout
from Internet.HTTP import :: HTTPRequest, :: HTTPResponse
from System.FilePath import :: FilePath
from System.Time import :: Timestamp
from Data.Error import :: MaybeError
from iTasks.WF.Definition import :: TaskId
from iTasks.Internal.IWorld import :: IWorld, :: BackgroundTaskId
from System.Time import :: Timestamp
from Data.Error import :: MaybeError
from iTasks.WF.Definition import :: TaskId
from iTasks.Internal.IWorld import :: IWorld, :: BackgroundTaskId
from iTasks.Internal.Task import :: ExternalProcessTask, :: ConnectionTask, :: BackgroundTask, :: TaskException
from iTasks.Internal.Engine import :: TaskWrapper
from iTasks.Engine import :: TaskWrapper
//Core task server loop
serve :: ![TaskWrapper] ![(!Int,!ConnectionTask)] ![BackgroundTask] (*IWorld -> (!Maybe Timeout,!*IWorld)) *IWorld -> *IWorld
......
......@@ -12,7 +12,7 @@ import qualified Data.Map as DM
import qualified iTasks.Internal.SDS as SDS
import TCPChannelClass, TCPChannels, TCPEvent, TCPStringChannels, TCPDef, tcp
import iTasks.Internal.Engine, iTasks.Internal.IWorld, iTasks.Internal.TaskEval, iTasks.Internal.TaskStore
import iTasks.Engine, iTasks.Internal.IWorld, iTasks.Internal.TaskEval, iTasks.Internal.TaskStore
import iTasks.Internal.IWorld
import iTasks.Internal.Task
import iTasks.Internal.TaskEval
......
......@@ -4,6 +4,7 @@ import StdOverloaded, StdBool, StdArray, StdTuple
from StdFunc import const, id, o
import Data.Maybe, Data.Either, Text, System.Time, Math.Random, Text.JSON, Data.Func, Data.Tuple, Data.List, Data.Error, System.FilePath, Data.Functor
import iTasks.Engine
import iTasks.Internal.IWorld, iTasks.Internal.TaskState, iTasks.Internal.Task, iTasks.Internal.Store
import iTasks.Internal.TaskEval, iTasks.Internal.Util, iTasks.UI.Definition
import iTasks.Internal.Serialization
......@@ -121,22 +122,22 @@ newDocumentId iworld=:{IWorld|random}
= (toString (take 32 [toChar (97 + abs (i rem 26)) \\ i <- random]) , {IWorld|iworld & random = drop 32 random})
createClientTaskInstance :: !(Task a) !String !InstanceNo !*IWorld -> *(!MaybeError TaskException TaskId, !*IWorld) | iTask a
createClientTaskInstance task sessionId instanceNo iworld=:{server={buildID},current={taskTime},clocks={timestamp,localDate,localTime}}
createClientTaskInstance task sessionId instanceNo iworld=:{options={appVersion},current={taskTime},clocks={timestamp,localDate,localTime}}
//Create the initial instance data in the store
# progress = {InstanceProgress|value=None,instanceKey="client",attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# constants = {InstanceConstants|session=True,listId=TaskId 0 0,build=buildID,issuedAt=timestamp}
# constants = {InstanceConstants|session=True,listId=TaskId 0 0,build=appVersion,issuedAt=timestamp}
= 'SDS'.write (instanceNo, Just constants,Just progress,Just defaultValue) (sdsFocus instanceNo taskInstance) iworld
`b` \iworld -> 'SDS'.write (createReduct defaultTonicOpts instanceNo task taskTime) (sdsFocus instanceNo taskInstanceReduct) iworld
`b` \iworld -> 'SDS'.write (TIValue NoValue) (sdsFocus instanceNo taskInstanceValue) iworld
`b` \iworld -> (Ok (TaskId instanceNo 0), iworld)
createTaskInstance :: !(Task a) !*IWorld -> (!MaybeError TaskException (!InstanceNo,InstanceKey),!*IWorld) | iTask a
createTaskInstance task iworld=:{server={buildID},current={taskTime},clocks={timestamp,localDate,localTime}}
createTaskInstance task iworld=:{options={appVersion},current={taskTime},clocks={timestamp,localDate,localTime}}
# (mbInstanceNo,iworld) = newInstanceNo iworld
# instanceNo = fromOk mbInstanceNo
# (instanceKey,iworld) = newInstanceKey iworld
# progress = {InstanceProgress|value=None,instanceKey=instanceKey,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# constants = {InstanceConstants|session=True,listId=TaskId 0 0,build=buildID,issuedAt=timestamp}
# constants = {InstanceConstants|session=True,listId=TaskId 0 0,build=appVersion,issuedAt=timestamp}
= 'SDS'.write (instanceNo, Just constants,Just progress,Just defaultValue) (sdsFocus instanceNo taskInstance) iworld
`b` \iworld -> 'SDS'.write (createReduct defaultTonicOpts instanceNo task taskTime) (sdsFocus instanceNo taskInstanceReduct) iworld
`b` \iworld -> 'SDS'.write (TIValue NoValue) (sdsFocus instanceNo taskInstanceValue) iworld
......@@ -147,10 +148,10 @@ createTaskInstance task iworld=:{server={buildID},current={taskTime},clocks={tim
(`b`) (Error e, st) _ = (Error e, st)
createDetachedTaskInstance :: !(Task a) !Bool !TaskEvalOpts !InstanceNo !TaskAttributes !TaskId !Bool !*IWorld -> (!MaybeError TaskException TaskId, !*IWorld) | iTask a
createDetachedTaskInstance task isTopLevel evalOpts instanceNo attributes listId refreshImmediate iworld=:{server={buildID},current={taskTime},clocks={timestamp,localDate,localTime}}
createDetachedTaskInstance task isTopLevel evalOpts instanceNo attributes listId refreshImmediate iworld=:{options={appVersion},current={taskTime},clocks={timestamp,localDate,localTime}}
# (instanceKey,iworld) = newInstanceKey iworld
# progress = {InstanceProgress|value=None,instanceKey=instanceKey,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# constants = {InstanceConstants|session=False,listId=listId,build=buildID,issuedAt=timestamp}
# constants = {InstanceConstants|session=False,listId=listId,build=appVersion,issuedAt=timestamp}
= 'SDS'.write (instanceNo,Just constants,Just progress,Just attributes) (sdsFocus instanceNo taskInstance) iworld
`b` \iworld -> 'SDS'.write (createReduct (if isTopLevel defaultTonicOpts evalOpts.tonicOpts) instanceNo task taskTime) (sdsFocus instanceNo taskInstanceReduct) iworld
`b` \iworld -> 'SDS'.write (TIValue NoValue) (sdsFocus instanceNo taskInstanceValue) iworld
......@@ -177,13 +178,13 @@ where
(ExceptionResult e,iworld) = (ExceptionResult e,iworld)
replaceTaskInstance :: !InstanceNo !(Task a) *IWorld -> (!MaybeError TaskException (), !*IWorld) | iTask a
replaceTaskInstance instanceNo task iworld=:{server={buildID},current={taskTime}}
replaceTaskInstance instanceNo task iworld=:{options={appVersion},current={taskTime}}
# (meta, iworld) = 'SDS'.read (sdsFocus instanceNo taskInstance) iworld
| isError meta = (liftError meta, iworld)
= 'SDS'.write (createReduct defaultTonicOpts instanceNo task taskTime) (sdsFocus instanceNo taskInstanceReduct) iworld
`b` \iworld -> 'SDS'.write (TIValue NoValue) (sdsFocus instanceNo taskInstanceValue) iworld
`b` \iworld -> let (_,Just constants,progress,attributes) = fromOk meta
in 'SDS'.write (instanceNo,Just {InstanceConstants|constants & build=buildID},progress,attributes) (sdsFocus instanceNo taskInstance) iworld
in 'SDS'.write (instanceNo,Just {InstanceConstants|constants & build=appVersion},progress,attributes) (sdsFocus instanceNo taskInstance) iworld
`b` \iworld -> (Ok (), iworld)
deleteTaskInstance :: !InstanceNo !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
......@@ -539,8 +540,8 @@ loadDocumentMeta documentId iworld
(Error e,iworld) = (Nothing,iworld)
documentLocation :: !DocumentId !*IWorld -> (!FilePath,!*IWorld)
documentLocation documentId iworld=:{server={buildID,paths={dataDirectory}}}
= (dataDirectory </>"stores"</> NS_DOCUMENT_CONTENT </> (documentId +++ "-data.txt"),iworld)
documentLocation documentId iworld=:{options={storeDirPath}}
= (storeDirPath </> NS_DOCUMENT_CONTENT </> (documentId +++ "-content"),iworld)
//OBSOLETE
exposedShare :: !String -> RWShared p r w | iTask r & iTask w & TC r & TC w & TC p & JSONEncode{|*|} p
......
......@@ -9,7 +9,7 @@ import qualified Data.Map as DM
import iTasks.Extensions.Development.Codebase
import Data.Func, Data.Either, Data.Error
from iTasks.Internal.IWorld import createIWorld, destroyIWorld, initJSCompilerState, ::IWorld{server}, :: ServerInfo(..), :: SystemPaths(..)
from iTasks.Internal.IWorld import createIWorld, destroyIWorld, initJSCompilerState, ::IWorld{options}
from iTasks.Internal.TaskStore import createTaskInstance, taskInstanceUIChanges
from iTasks.Internal.TaskEval import evalTaskInstance
from iTasks.Internal.Store import emptyStore
......@@ -130,9 +130,8 @@ testTaskOutput :: String (Task a) [Either Event Int] [UIChange] ([UIChange] [UIC
testTaskOutput name task events exp comparison = utest name test
where
test world
# (argv,world) = getCommandLine world
# (appPath,world) = toCanonicalPath (hd argv) world
# iworld = createIWorld "TEST" appPath False Nothing Nothing Nothing world
# (options,world) = defaultEngineOptions world
# iworld = createIWorld options world
//Initialize JS compiler support
# (res,iworld) = initJSCompilerState iworld
| res =:(Error _)
......
implementation module iTasks.Internal.Test.Stubs
import iTasks.Engine
import iTasks.Internal.IWorld
import iTasks.Internal.Generic.Defaults
import iTasks.UI.Editor
......@@ -11,9 +12,8 @@ import qualified Data.Map as DM
toStubIWorld :: *World -> *IWorld
toStubIWorld world
= {IWorld
|server = {serverName = "STUB",serverURL = "//127.0.0.1:80",buildID = "STUB"
,paths = {appDirectory = "./STUB/",dataDirectory = "./STUB/",webDirectory = "./STUB/",saplDirectory = "./STUB/"}}
,config = {sessionTime = 3600, smtpServer = "localhost",persistTasks = True}
|options = {EngineOptions|appName="STUB",appPath="./",appVersion="STUB",serverPort=80,serverUrl="/127.0.0.1:80/",keepaliveTime=0,sessionTime=0
,persistTasks=False,webDirPath="./STUB/",storeDirPath="./STUB/",tempDirPath="./STUB/",saplDirPath="./STUB"}
,clocks = {SystemClocks |timestamp = Timestamp 0,localDate=defaultValue,localTime=defaultValue,utcDate=defaultValue,utcTime=defaultValue}
,current ={TaskEvalState|taskTime= 0,taskInstance= 0,sessionInstance = Nothing,attachmentChain = [] ,nextTaskNo = 0}
,sdsNotifyRequests = [], memoryShares = 'DM'.newMap, readCache = 'DM'.newMap, writeCache = 'DM'.newMap, exposedShares = 'DM'.newMap
......
......@@ -2,7 +2,7 @@ definition module iTasks.Internal.Tonic
from iTasks.Internal.SDS import :: Shared, :: ReadWriteShared, :: RWShared
from iTasks.Internal.IWorld import :: IWorld, :: SystemClocks
from iTasks.Internal.Engine import :: PublishedTask
from iTasks.Engine import :: PublishedTask
from iTasks.Internal.Task import :: TaskEvalOpts, :: TaskResult
from iTasks.WF.Definition import :: Task, :: InstanceNo, class iTask
from iTasks.WF.Combinators.Tune import class tune
......
implementation module iTasks.Internal.Tonic
import iTasks.Internal.Engine
import iTasks.Engine
import iTasks.Internal.SDS
import qualified iTasks.Internal.SDS as DSDS
import iTasks.Internal.IWorld
......
......@@ -4,7 +4,7 @@ import iTasks
import StdMisc, Data.Tuple, Text, Data.Either, Data.Functor
import iTasks.Internal.SDS
import iTasks.Internal.Tonic.Blueprints
import iTasks.Internal.Engine
import iTasks.Engine
import iTasks.Internal.SDS