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

Commit bdbc3f34 authored by Bas Lijnse's avatar Bas Lijnse

Implemented basic version of switching off persisten task state

parent a515d3ea
......@@ -131,7 +131,7 @@ createClientIWorld serverURL currentInstance
,webDirectory = locundef "webDirectory"
,saplDirectory = locundef "saplDirectory"}
}
,config = {sessionTime = 3600, smtpServer = locundef "smtpServer"}
,config = {sessionTime = 3600, smtpServer = locundef "smtpServer", persistTasks = True}
,clocks =
{ timestamp = timestamp
, localDate = {Date|day = 1, mon = 1, year = 1977}
......
......@@ -29,6 +29,7 @@ MAX_EVENTS :== 5
, appPath :: FilePath
, serverPort :: Int
, keepalive :: Int
, persistTasks :: Bool
, webDirPath :: Maybe FilePath
, storeDirPath :: Maybe FilePath
, saplDirPath :: Maybe FilePath
......
......@@ -45,6 +45,7 @@ getServerOptions world
# port = fromMaybe DEFAULT_PORT (intOpt "-port" opts)
# keepalive = fromMaybe DEFAULT_KEEPALIVE_TIME (intOpt "-keepalive" opts)
# help = boolOpt "-help" opts
# noPersist = boolOpt "-no-persist" opts
# webOpt = stringOpt "-webpublic" opts
# storeOpt = stringOpt "-store" opts
# saplOpt = stringOpt "-sapl" opts
......@@ -58,6 +59,7 @@ getServerOptions world
, webDirPath = webOpt
, storeDirPath = storeOpt
, saplDirPath = saplOpt
, persistTasks = not noPersist
}
= (Just options,world)
where
......@@ -99,9 +101,9 @@ startEngine publishable world
(Just options,world) = startEngineWithOptions publishable options world
startEngineWithOptions :: a ServerOptions !*World -> *World | Publishable a
startEngineWithOptions publishable options=:{appName,appPath,serverPort,keepalive,webDirPath,storeDirPath,saplDirPath} world
startEngineWithOptions publishable options=:{appName,appPath,serverPort,keepalive,persistTasks,webDirPath,storeDirPath,saplDirPath} world
# world = show (running appName serverPort) world
# iworld = createIWorld appName appPath webDirPath storeDirPath saplDirPath world
# iworld = createIWorld appName appPath persistTasks webDirPath storeDirPath saplDirPath world
# (res,iworld) = initJSCompilerState iworld
| res =:(Error _) = show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
//Start task server
......@@ -126,8 +128,8 @@ runTasks tasks world
(Just options,world) = runTasksWithOptions tasks options world
runTasksWithOptions :: a ServerOptions !*World -> *World | Runnable a
runTasksWithOptions runnable options=:{appName,appPath,serverPort,keepalive,webDirPath,storeDirPath,saplDirPath} world
# iworld = createIWorld appName appPath webDirPath storeDirPath saplDirPath world
runTasksWithOptions runnable options=:{appName,appPath,serverPort,keepalive,persistTasks,webDirPath,storeDirPath,saplDirPath} world
# iworld = createIWorld appName appPath persistTasks webDirPath storeDirPath saplDirPath world
# (res,iworld) = initJSCompilerState iworld
| res =:(Error _) = show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
# iworld = serve (toRunnable runnable) [] systemTasks timeout iworld
......
......@@ -55,6 +55,8 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
:: 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 =
......@@ -159,6 +161,7 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
*
* @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)
......@@ -166,7 +169,7 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
*
* @return An initialized iworld
*/
createIWorld :: !String FilePath !(Maybe FilePath) !(Maybe FilePath) !(Maybe FilePath) !*World -> *IWorld
createIWorld :: !String FilePath !Bool !(Maybe FilePath) !(Maybe FilePath) !(Maybe FilePath) !*World -> *IWorld
/**
* Initialize the SAPL->JS compiler state
......
......@@ -55,8 +55,8 @@ JS_COMPILER_EXCLUDES :==
,"System.Directory"
]
createIWorld :: !String FilePath !(Maybe FilePath) !(Maybe FilePath) !(Maybe FilePath) !*World -> *IWorld
createIWorld appName appPath mbWebdirPath mbStorePath mbSaplPath world
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
......@@ -86,7 +86,7 @@ createIWorld appName appPath mbWebdirPath mbStorePath mbSaplPath world
,saplDirectory = saplDir
}
}
,config = initialConfig
,config = initialConfig persistTasks
,clocks =
{SystemClocks
|timestamp=timestamp
......@@ -117,10 +117,10 @@ createIWorld appName appPath mbWebdirPath mbStorePath mbSaplPath world
,onClient = False
}
where
initialConfig :: Config
initialConfig =
initialConfig persistTasks =
{ sessionTime = 3600
, smtpServer = "localhost"
, persistTasks = persistTasks
}
ensureDir :: !String !FilePath *World -> (!Bool,!*World)
......
......@@ -43,6 +43,13 @@ NS_JAVASCRIPT_CACHE :== "js-cache"
instance toString StoreReadError
derive class iTask StoreReadError
//For system stores, the server configuration determines if and when data is written to disk
//This storage preference type is used to indicate
:: StoragePreference
= StoreInMemory //When the data is disposable. It will be gone when the application shuts down
| StoreInJSONFile //When the data should be persisted between different versions of an application
| StoreInDynamicFile //When the data contains functions, dynamics or otherwise
/**
* Creates a store in memory. Values in this store are lost when the server shuts down.
*
......@@ -61,6 +68,17 @@ memoryStore :: !StoreNamespace !(Maybe a) -> RWShared StoreName a a | TC a
*/
fullFileStore :: !StoreNamespace !Bool !(Maybe {#Char}) -> RWShared StoreName (!BuildID,!{#Char}) {#Char}
/**
* Creates a store that is either in-memory, or persisted to disk depending on the global configuation option
*
* @param The namespace in the store
* @param Check the build version
* @param Automatically reset the the store if an error occurs
* @param Cache the value
* @param Optionally a default content to be used on first read. If nothing is given an error will occur when reading before writing.
*/
systemStore :: !StoreNamespace !StoragePreference !Bool !Bool !Bool !(Maybe a) -> RWShared StoreName a a | JSONEncode{|*|}, JSONDecode{|*|}, TC a
/**
* Extends a fullFileStore with JSON encoding/decoding such that arbitrary values can be stored.
* It also adds optional buildID checking to make sure that JSONEncoded functions and dynamics are
......
......@@ -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 {onClient,server,memoryShares,cachedShares,world}, :: ServerInfo(..), :: SystemPaths(..), :: Resource, :: ShareCache(..), :: CachedValue(..)
from iTasks.Internal.IWorld import :: IWorld {config,onClient,server,memoryShares,cachedShares,world}, :: ServerInfo(..), :: SystemPaths(..), :: Resource, :: ShareCache(..), :: CachedValue(..)
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.Internal.IWorld import :: Config(..)
from iTasks.WF.Definition import class iTask
from iTasks.Internal.Generic.Visualization import generic gText, :: TextFormat(..), toMultiLineText
......@@ -39,58 +39,86 @@ derive class iTask StoreReadError
//Temporary memory storage
memoryStore :: !StoreNamespace !(Maybe a) -> RWShared StoreName a a | TC a
memoryStore namespace defaultV = createReadWriteSDS namespace "memoryStore" read write
memoryStore namespace defaultV
= createReadWriteSDS namespace "memoryStore" (memoryStoreRead namespace defaultV) (memoryStoreWrite namespace)
memoryStoreRead namespace defaultV key iworld=:{IWorld|memoryShares}
= case 'DM'.get (namespace,key) memoryShares of
(Just (val :: a^)) = (Ok val,iworld)
(Just _) = (Error (exception (StoreReadTypeError storeDesc)), iworld)
_ = case defaultV of
Nothing = (Error (exception (StoreReadMissingError storeDesc)), iworld)
Just val = (Ok val, {IWorld|iworld & memoryShares = 'DM'.put (namespace,key) (dynamic val :: a^) memoryShares})
where
read key iworld=:{IWorld|memoryShares}
= case 'DM'.get (namespace,key) memoryShares of
(Just (val :: a^)) = (Ok val,iworld)
(Just _) = (Error (exception (StoreReadTypeError storeDesc)), iworld)
_ = case defaultV of
Nothing = (Error (exception (StoreReadMissingError storeDesc)), iworld)
Just val = (Ok val, {IWorld|iworld & memoryShares = 'DM'.put (namespace,key) (dynamic val :: a^) memoryShares})
where
storeDesc = namespace +++ "/" +++ key
write key val iworld=:{IWorld|memoryShares}
= (Ok ((==) key),{IWorld|iworld & memoryShares = 'DM'.put (namespace,key) (dynamic val :: a^) memoryShares})
storeDesc = namespace +++ "/" +++ key
memoryStoreWrite namespace key val iworld=:{IWorld|memoryShares}
= (Ok ((==) key),{IWorld|iworld & memoryShares = 'DM'.put (namespace,key) (dynamic val :: a^) memoryShares})
//'Core' file storage SDS
fullFileStore :: !StoreNamespace !Bool !(Maybe {#Char}) -> RWShared StoreName (!BuildID,!{#Char}) {#Char}
fullFileStore namespace resetOnError defaultV = createReadWriteSDS namespace "fullFileStore" read write
where
read key iworld=:{IWorld|onClient,server={buildID}}
| onClient //Special case for tasks running on a client
# (mbVal,iworld) = jsLoadValue namespace key iworld
= (maybe (Error (exception (StoreReadMissingError storeDesc))) Ok mbVal, iworld)
# (mbItem,iworld) = readFromDisk namespace key iworld
= case (mbItem,defaultV) of
(Ok item,_)
= (Ok item,iworld)
(Error (StoreReadMissingError desc),Just def)
# (mbErr,iworld) = writeToDisk namespace key def iworld
| mbErr =: (Error _)
= (Error (exception (fromError mbErr)),iworld)
= (Ok (buildID,def),iworld)
(Error e,Just def) | resetOnError
# (mbErr,iworld) = writeToDisk namespace key def iworld
| mbErr =: (Error _)
= (Error (exception (fromError mbErr)),iworld)
= (Ok (buildID,def),iworld)
(Error e,Nothing) | resetOnError
# (_,iworld) = deleteValue namespace key iworld //Try to delete the value
= (Error (exception e), iworld)
(Error e,_)
= (Error (exception e),iworld)
where
storeDesc = namespace +++ "/" +++ key
fullFileStore namespace resetOnError defaultV
= createReadWriteSDS namespace "fullFileStore" (fileStoreRead namespace resetOnError defaultV) (fileStoreWrite namespace resetOnError defaultV)
write key value iworld=:{IWorld|onClient}
| onClient //Special case for tasks running on a client
= (Ok ((==) key),jsStoreValue namespace key value iworld)
| otherwise
# (mbErr,iworld) = writeToDisk namespace key value iworld
fileStoreRead namespace resetOnError defaultV key iworld=:{IWorld|onClient,server={buildID}}
| onClient //Special case for tasks running on a client
# (mbVal,iworld) = jsLoadValue namespace key iworld
= (maybe (Error (exception (StoreReadMissingError storeDesc))) Ok mbVal, iworld)
# (mbItem,iworld) = readFromDisk namespace key iworld
= case (mbItem,defaultV) of
(Ok item,_)
= (Ok item,iworld)
(Error (StoreReadMissingError desc),Just def)
# (mbErr,iworld) = writeToDisk namespace key def iworld
| mbErr =: (Error _)
= (Error (exception (fromError mbErr)),iworld)
= (Ok ((==) key),iworld)
= (Ok (buildID,def),iworld)
(Error e,Just def) | resetOnError
# (mbErr,iworld) = writeToDisk namespace key def iworld
| mbErr =: (Error _)
= (Error (exception (fromError mbErr)),iworld)
= (Ok (buildID,def),iworld)
(Error e,Nothing) | resetOnError
# (_,iworld) = deleteValue namespace key iworld //Try to delete the value
= (Error (exception e), iworld)
(Error e,_)
= (Error (exception e),iworld)
where
storeDesc = namespace +++ "/" +++ key
fileStoreWrite namespace resetOnError defaultV key value iworld=:{IWorld|onClient}
| onClient //Special case for tasks running on a client
= (Ok ((==) key),jsStoreValue namespace key value iworld)
| otherwise
# (mbErr,iworld) = writeToDisk namespace key value iworld
| mbErr =: (Error _)
= (Error (exception (fromError mbErr)),iworld)
= (Ok ((==) key),iworld)
systemStore :: !StoreNamespace !StoragePreference !Bool !Bool !Bool !(Maybe a) -> RWShared StoreName a a | JSONEncode{|*|}, JSONDecode{|*|}, TC a
systemStore namespace preference checkBuild cache resetOnError defaultV
= createReadWriteSDS namespace "systemStore" systemStoreRead systemStoreWrite
where
systemStoreRead key iworld=:{IWorld|config={persistTasks}}
| persistTasks = case preference of
StoreInMemory = memoryStoreRead namespace defaultV key iworld
StoreInJSONFile = read (sdsFocus key (cachedJSONFileStore namespace checkBuild resetOnError cache defaultV)) iworld
StoreInDynamicFile = read (sdsFocus key (cachedDynamicStringFileStore namespace checkBuild resetOnError cache defaultV)) iworld
| otherwise
= memoryStoreRead namespace defaultV key iworld
systemStoreWrite key value iworld=:{IWorld|config={persistTasks}}
| persistTasks = case preference of
StoreInMemory = memoryStoreWrite namespace key value iworld
StoreInJSONFile = case write value (sdsFocus key (cachedJSONFileStore namespace checkBuild resetOnError cache defaultV)) iworld of
(Ok (), iworld) = (Ok (const False),iworld)
(Error e,iworld) = (Error e, iworld)
StoreInDynamicFile = case write value (sdsFocus key (cachedDynamicStringFileStore namespace checkBuild resetOnError cache defaultV)) iworld of
(Ok (), iworld) = (Ok (const False),iworld)
(Error e,iworld) = (Error e, iworld)
| otherwise
= memoryStoreWrite namespace key value iworld
//Utility SDS which provides the current build such that higher level stores can check against it
buildID :: RWShared p BuildID ()
......
......@@ -170,7 +170,6 @@ attachViewport :: !InstanceNo !*IWorld -> *IWorld
*/
detachViewport :: !InstanceNo !*IWorld -> *IWorld
//Documents
createDocument :: !String !String !String !*IWorld -> (!MaybeError FileError Document, !*IWorld)
loadDocumentContent :: !DocumentId !*IWorld -> (!Maybe String, !*IWorld)
......
......@@ -34,13 +34,28 @@ derive gEq ParallelTaskChange
derive gText ParallelTaskChange
derive class iTask InstanceFilter
//Master instance index on disk
//Unfiltered administration
rawTaskIndex = systemStore NS_TASK_INSTANCES StoreInJSONFile False False True (Just [])
rawTaskNoCounter = systemStore NS_TASK_INSTANCES StoreInJSONFile False False True (Just 1)
rawInstanceIO = systemStore NS_TASK_INSTANCES StoreInMemory False False False (Just 'DM'.newMap)
rawInstanceEvents = systemStore NS_TASK_INSTANCES StoreInJSONFile False False True (Just 'DQ'.newQueue)
rawInstanceUIChanges = systemStore NS_TASK_INSTANCES StoreInMemory False False False (Just 'DM'.newMap)
rawInstanceReduct = systemStore NS_TASK_INSTANCES StoreInDynamicFile True False False Nothing
rawInstanceValue = systemStore NS_TASK_INSTANCES StoreInDynamicFile True False False Nothing
rawInstanceShares = systemStore NS_TASK_INSTANCES StoreInDynamicFile True False False (Just 'DM'.newMap)
rawInstanceParallels = systemStore NS_TASK_INSTANCES StoreInDynamicFile True False False (Just 'DM'.newMap)
//Master instance index
taskInstanceIndex :: RWShared () [TIMeta] [TIMeta]
taskInstanceIndex = sdsFocus "instances" (cachedJSONFileStore NS_TASK_INSTANCES False False True (Just []))
taskInstanceIndex = sdsFocus "instances" rawTaskIndex
//Next instance no counter
nextInstanceNo :: RWShared () Int Int
nextInstanceNo = sdsFocus "increment" (cachedJSONFileStore NS_TASK_INSTANCES False False True (Just 1))
nextInstanceNo = sdsFocus "increment" rawTaskNoCounter
taskInstanceIO :: RWShared InstanceNo (Maybe (!String,!Timestamp)) (Maybe (!String,!Timestamp))
taskInstanceIO = sdsLens "taskInstanceIO" (const ()) (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) allInstanceIO
......@@ -51,27 +66,26 @@ where
notify instanceNo _ = (==) instanceNo
allInstanceIO :: RWShared () (Map InstanceNo (!String,!Timestamp)) (Map InstanceNo (!String,Timestamp))
allInstanceIO = sdsFocus "io" (memoryStore NS_TASK_INSTANCES (Just 'DM'.newMap))
allInstanceIO = sdsFocus "io" rawInstanceIO
//Event queues of task instances
taskEvents :: RWShared () (Queue (InstanceNo,Event)) (Queue (InstanceNo,Event))
taskEvents = sdsFocus "events" (cachedJSONFileStore NS_TASK_INSTANCES False False True (Just 'DQ'.newQueue))
taskEvents = sdsFocus "events" rawInstanceEvents
//Instance evaluation state
taskInstanceReduct :: RWShared InstanceNo TIReduct TIReduct
//taskInstanceReduct = sdsTranslate "taskInstanceReduct" (\t -> t +++> "-reduct") (memoryStore NS_TASK_INSTANCES Nothing)
taskInstanceReduct = sdsTranslate "taskInstanceReduct" (\t -> t +++> "-reduct") (cachedDynamicStringFileStore NS_TASK_INSTANCES True False False Nothing)
taskInstanceReduct = sdsTranslate "taskInstanceReduct" (\t -> t +++> "-reduct") rawInstanceReduct
//Last computed value for task instance
taskInstanceValue :: RWShared InstanceNo TIValue TIValue
taskInstanceValue = sdsTranslate "taskInstanceValue" (\t -> t +++> "-value") (cachedDynamicStringFileStore NS_TASK_INSTANCES True False False Nothing)
taskInstanceValue = sdsTranslate "taskInstanceValue" (\t -> t +++> "-value") rawInstanceValue
//Local shared data
taskInstanceShares :: RWShared InstanceNo (Map TaskId JSONNode) (Map TaskId JSONNode)
taskInstanceShares = sdsTranslate "taskInstanceShares" (\t -> t +++> "-shares") (cachedDynamicStringFileStore NS_TASK_INSTANCES True False False (Just 'DM'.newMap))
taskInstanceShares = sdsTranslate "taskInstanceShares" (\t -> t +++> "-shares") rawInstanceShares
allUIChanges :: RWShared () (Map InstanceNo (Queue UIChange)) (Map InstanceNo (Queue UIChange))
allUIChanges = sdsFocus "allUIChanges" (memoryStore NS_TASK_INSTANCES (Just 'DM'.newMap))
allUIChanges = sdsFocus "allUIChanges" rawInstanceUIChanges
taskInstanceUIChanges :: RWShared InstanceNo (Queue UIChange) (Queue UIChange)
taskInstanceUIChanges = sdsLens "taskInstanceUIChanges" (const ()) (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) allUIChanges
......@@ -85,7 +99,7 @@ where
//Task instance parallel lists
taskInstanceParallelTaskLists :: RWShared InstanceNo (Map TaskId [ParallelTaskState]) (Map TaskId [ParallelTaskState])
taskInstanceParallelTaskLists = sdsTranslate "taskInstanceParallelLists" (\t -> t +++> "-tasklists") (cachedDynamicStringFileStore NS_TASK_INSTANCES True False False (Just 'DM'.newMap))
taskInstanceParallelTaskLists = sdsTranslate "taskInstanceParallelLists" (\t -> t +++> "-tasklists") rawInstanceParallels
newInstanceNo :: !*IWorld -> (!MaybeError TaskException InstanceNo,!*IWorld)
newInstanceNo iworld
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment