Commit 2418c970 authored by Bas Lijnse's avatar Bas Lijnse

Improved updating of attributes of detached instances

parent c2ce79ec
......@@ -93,7 +93,7 @@ where
# (nextTaskNo,iworld) = getNextTaskNo iworld
# (mbErr,iworld) = if destroyed
(Ok (),iworld) //Only update progress when something changed
(case (modify (updateProgress clock newResult nextTaskNo nextTaskTime) (sdsFocus (instanceNo,False,True,False) taskInstance) EmptyContext iworld) of
(case (modify (updateProgress clock newResult nextTaskNo nextTaskTime) (sdsFocus (instanceNo,False,True) taskInstance) EmptyContext iworld) of
(Error e, iworld) = (Error e, iworld)
(Ok _, iworld) = (Ok (), iworld) )
| mbErr=:(Error _)
......@@ -116,15 +116,8 @@ where
| destroyed = (Ok value,iworld)
| otherwise = case compactUIChange change of
//Only queue UI changes if something interesting is changed
NoChange
= (Ok value,iworld)
change
# (mbErr,iworld) = modify
(\(managementAttributes,taskAttributes)-> (managementAttributes, foldr applyUIAttributeChange taskAttributes (getAttributeChanges change)))
(sdsFocus instanceNo taskInstanceAttributes) EmptyContext iworld
| mbErr=:(Error _)
= exitWithException instanceNo "failed to update attributes" iworld
= (Ok value, queueUIChange instanceNo change iworld)
NoChange = (Ok value,iworld)
change = (Ok value, queueUIChange instanceNo change iworld)
ExceptionResult (e,description)
# iworld = if (type =: StartupInstance)
(printStdErr description {iworld & shutdown=Just 1})
......@@ -138,13 +131,13 @@ where
= (Error description, iworld)
determineInstanceType instanceNo iworld
# (meta, iworld) = 'SDS'.read (sdsFocus (instanceNo,False,False,False) taskInstance) EmptyContext iworld
# (meta, iworld) = 'SDS'.read (sdsFocus (instanceNo,False,False) taskInstance) EmptyContext iworld
| isError meta = (SessionInstance,iworld)
# {TaskMeta|instanceType} = directResult (fromOk meta)
= (instanceType,iworld)
determineInstanceProgress instanceNo iworld
# (meta,iworld) = 'SDS'.read (sdsFocus (instanceNo,False,False,False) taskInstance) EmptyContext iworld
# (meta,iworld) = 'SDS'.read (sdsFocus (instanceNo,False,False) taskInstance) EmptyContext iworld
| isError meta = ({defaultValue & nextTaskNo=1, nextTaskTime=1},iworld)
= (directResult (fromOk meta),iworld)
......@@ -154,21 +147,26 @@ where
# attachedTo = case meta.TaskMeta.attachedTo of //Release temporary attachment after first evaluation
(Just (_,[])) = Nothing
attachment = attachment
# meta = {TaskMeta
| meta
& firstEvent = Just (fromMaybe now meta.TaskMeta.firstEvent)
, lastEvent = Just now
, nextTaskNo = nextTaskNo
, nextTaskTime = nextTaskTime + 1
}
= case result of
(ExceptionResult (_,msg)) = {TaskMeta|meta & status = Left msg}
(ValueResult (Value _ stable) _ _ _) = {TaskMeta|meta & status = Right stable}
_ = {TaskMeta|meta & status = Right False}
getAttributeChanges :: !UIChange -> [UIAttributeChange]
getAttributeChanges (ChangeUI changes _) = changes
getAttributeChanges (ReplaceUI (UI _ attrs _)) = [SetAttribute attr val \\ (attr,val) <- 'DM'.toList attrs]
# status = case result of
(ExceptionResult (_,msg)) = Left msg
(ValueResult (Value _ stable) _ _ _) = Right stable
_ = Right False
# taskAttributes = case result of
(ValueResult _ _ change _) = foldr applyUIAttributeChange meta.TaskMeta.taskAttributes $ getAttributeChanges change
_ = meta.TaskMeta.taskAttributes
= {TaskMeta| meta
& status = status
, firstEvent = Just (fromMaybe now meta.TaskMeta.firstEvent)
, lastEvent = Just now
, nextTaskNo = nextTaskNo
, nextTaskTime = nextTaskTime + 1
, taskAttributes = taskAttributes
}
where
getAttributeChanges :: !UIChange -> [UIAttributeChange]
getAttributeChanges NoChange = []
getAttributeChanges (ChangeUI changes _) = changes
getAttributeChanges (ReplaceUI (UI _ attrs _)) = [SetAttribute attr val \\ (attr,val) <- 'DM'.toList attrs]
mbResetUIState instanceNo ResetEvent iworld
# (_,iworld) = write 'DQ'.newQueue (sdsFocus instanceNo taskInstanceOutput) EmptyContext iworld
......
......@@ -53,27 +53,29 @@ derive gText ExtendedTaskListFilter
:: TaskMeta =
//Static information
{ taskId :: !TaskId //Unique global identification
, instanceType :: !InstanceType //There are 3 types of tasks: startup tasks, sessions, and persistent tasks
, build :: !String //* Application build version when the instance was created
, createdAt :: !Timespec
//Evaluation information
, status :: !Either String Bool //* Exception message, or stability
, nextTaskNo :: !TaskNo //* Local task number counter
, nextTaskTime :: !TaskTime //* Local task time (incremented at every evaluation)
, attachedTo :: ![TaskId]
, connectedTo :: !Maybe String
, instanceKey :: !Maybe InstanceKey //* Random token that a client gets to have (temporary) access to the task instance
, firstEvent :: !Maybe Timespec //* When was the first work done on this task
, lastEvent :: !Maybe Timespec //* When was the latest event on this task (excluding Refresh events)
, lastIO :: !Maybe Timespec
{ taskId :: !TaskId //Unique global identification
, instanceType :: !InstanceType //There are 3 types of tasks: startup tasks, sessions, and persistent tasks
, build :: !String //* Application build version when the instance was created
, createdAt :: !Timespec
, detachedFrom :: !Maybe TaskId //* Which parallel task created the entry (or none when added globally)
//Progress information
, status :: !Either String Bool //* Exception message, or stability
, nextTaskNo :: !TaskNo //* Local task number counter
, nextTaskTime :: !TaskTime //* Local task time (incremented at every evaluation)
, attachedTo :: ![TaskId]
, instanceKey :: !Maybe InstanceKey //* Random token that a client gets to have (temporary) access to the task instance
, taskAttributes :: !TaskAttributes //* Attributes computed by the UI
//IO information
, connectedTo :: !Maybe String //* Client machine to which this task is connected
, firstEvent :: !Maybe Timespec //* When was the first work done on this task
, lastEvent :: !Maybe Timespec //* When was the latest event on this task (excluding Refresh events)
, lastIO :: !Maybe Timespec //* Last network event or ping
//Identification and classification information
, taskAttributes :: !TaskAttributes //Cached attributes from the task UI
, managementAttributes :: !TaskAttributes //Arbitrary writable attributes for managing collections of task instances
, unsyncedAttributes :: !Set String //When the `managementAttributes` are written they need to be synced to the UI on the next evaluation
// Control information
, change :: !Maybe TaskChange //Changes like removing or replacing a parallel task are only done when the
, initialized :: !Bool //TODO: Get rid of in this record
, managementAttributes :: !TaskAttributes //* Arbitrary writable attributes for managing collections of task instances
// Control information (used only internally)
, change :: !Maybe TaskChange //* Changes like removing or replacing a parallel task are only done when the
, initialized :: !Bool
, unsyncedAttributes :: !Set String //* When the `managementAttributes` are written they need to be synced to the UI on the next evaluation
}
/**
......@@ -85,13 +87,12 @@ derive gText ExtendedTaskListFilter
:: InstanceType
= StartupInstance
| SessionInstance
| PersistentInstance !(Maybe TaskId) //* If the task is a sub-task a detached part of another instance
| PersistentInstance
:: TaskChange
= RemoveTask //Mark for removal from the set on the next evaluation
| ReplaceTask !Dynamic //Replace the task on the next evaluation
//Internally we need more options to filter task list data
:: ExtendedTaskListFilter =
//Extra filter on task type
......@@ -138,10 +139,7 @@ taskInstanceParallelTaskListTask :: SDSLens (TaskId,TaskId) (Task a) (Task a)
//Interface used during the evalation of toplevel tasks
//Filtered views on the instance index
taskInstance :: SDSLens (InstanceNo,Bool,Bool,Bool) TaskMeta TaskMeta
taskInstanceAttributes :: SDSLens InstanceNo (TaskAttributes,TaskAttributes) (TaskAttributes,TaskAttributes)
taskInstance :: SDSLens (InstanceNo,Bool,Bool) TaskMeta TaskMeta
taskInstanceValue :: SDSLens InstanceNo (TaskValue DeferredJSON) (TaskValue DeferredJSON)
taskInstanceTask :: SDSLens InstanceNo (Task DeferredJSON) (Task DeferredJSON)
......@@ -175,10 +173,10 @@ createSessionTaskInstance :: !(Task a) !TaskAttributes !*IWorld -> (!MaybeError
* @param If the instance needs to be evaluated immediately, the attachment is temporarily set to the issuer
* @param The IWorld state
*
* @return The task id of the stored instance
* @return The task-list record of the stored instance
* @return The IWorld state
*/
createDetachedTaskInstance :: !(Task a) !TaskEvalOpts !InstanceNo !TaskAttributes !TaskId !Bool !*IWorld -> (!MaybeError TaskException TaskId, !*IWorld) | iTask a
createDetachedTaskInstance :: !(Task a) !TaskEvalOpts !InstanceNo !TaskAttributes !TaskId !Bool !*IWorld -> (!MaybeError TaskException TaskMeta, !*IWorld) | iTask a
/**
* Replace a stored task instance in the task store.
......
......@@ -54,8 +54,8 @@ derive JSONDecode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo,
derive gDefault InstanceType, TaskId, TaskListFilter
gDefault{|TaskMeta|}
= {taskId= TaskId 0 0,instanceType=gDefault{|*|},build="",createdAt=gDefault{|*|},nextTaskNo=1,nextTaskTime=1
,status=Right False,attachedTo=[],connectedTo=Nothing,instanceKey=Nothing
= {taskId= TaskId 0 0,instanceType=PersistentInstance,build="",createdAt=gDefault{|*|},nextTaskNo=1,nextTaskTime=1
,detachedFrom=Nothing,status=Right False,attachedTo=[],connectedTo=Nothing,instanceKey=Nothing
,firstEvent=Nothing,lastEvent=Nothing, lastIO = Nothing
,taskAttributes='DM'.newMap,managementAttributes='DM'.newMap,unsyncedAttributes = 'DS'.newSet
,change = Nothing, initialized = False}
......@@ -122,7 +122,8 @@ createClientTaskInstance :: !(Task a) !String !InstanceNo !*IWorld -> *(!MaybeEr
createClientTaskInstance task sessionId instanceNo iworld=:{options={appVersion},current={taskTime},clock}
//Create the initial instance data in the store
# meta = {defaultValue & taskId= TaskId instanceNo 0, instanceType=SessionInstance,build=appVersion,createdAt=clock}
= 'SDS'.write meta (sdsFocus (instanceNo,False,False,False) taskInstance) 'SDS'.EmptyContext iworld
= 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok (TaskId instanceNo 0), iworld)
......@@ -133,7 +134,8 @@ createSessionTaskInstance task attributes iworld=:{options={appVersion,autoLayou
# (instanceKey,iworld) = newInstanceKey iworld
# meta = {defaultValue & taskId= TaskId instanceNo 0,instanceType=SessionInstance
,instanceKey = Just instanceKey,build=appVersion,createdAt=clock,taskAttributes=attributes}
= 'SDS'.write meta (sdsFocus (instanceNo,False,False,False) taskInstance) 'SDS'.EmptyContext iworld
= 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok (instanceNo,instanceKey), iworld)
......@@ -141,31 +143,31 @@ createStartupTaskInstance :: !(Task a) !TaskAttributes !*IWorld -> (!MaybeError
createStartupTaskInstance task attributes iworld=:{options={appVersion,autoLayout},current={taskTime},clock}
# (Ok instanceNo,iworld) = newInstanceNo iworld
# meta = {defaultValue & taskId= TaskId instanceNo 0,instanceType=StartupInstance,build=appVersion,createdAt=clock,taskAttributes=attributes}
= 'SDS'.write meta (sdsFocus (instanceNo,False,False,False) taskInstance) 'SDS'.EmptyContext iworld
= 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok instanceNo, queueEvent instanceNo ResetEvent iworld)
createDetachedTaskInstance :: !(Task a) !TaskEvalOpts !InstanceNo !TaskAttributes !TaskId !Bool !*IWorld -> (!MaybeError TaskException TaskId, !*IWorld) | iTask a
createDetachedTaskInstance :: !(Task a) !TaskEvalOpts !InstanceNo !TaskAttributes !TaskId !Bool !*IWorld -> (!MaybeError TaskException TaskMeta, !*IWorld) | iTask a
createDetachedTaskInstance task evalOpts instanceNo attributes listId refreshImmediate iworld=:{options={appVersion,autoLayout},current={taskTime},clock}
# task = if autoLayout (ApplyLayout defaultSessionLayout @>> task) task
# (instanceKey,iworld) = newInstanceKey iworld
# mbListId = if (listId == TaskId 0 0) Nothing (Just listId)
# meta = {defaultValue & taskId = TaskId instanceNo 0, instanceType=PersistentInstance mbListId,build=appVersion
# meta = {defaultValue & taskId = TaskId instanceNo 0, instanceType=PersistentInstance,build=appVersion
,createdAt=clock,managementAttributes=attributes, instanceKey=Just instanceKey}
= 'SDS'.write meta (sdsFocus (instanceNo,False,False,False) taskInstance) 'SDS'.EmptyContext iworld
= 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> ( Ok (TaskId instanceNo 0)
, if refreshImmediate
(queueEvent instanceNo ResetEvent iworld)
iworld)
`b` \iworld -> ( Ok meta, if refreshImmediate (queueEvent instanceNo ResetEvent iworld) iworld)
replaceTaskInstance :: !InstanceNo !(Task a) *IWorld -> (!MaybeError TaskException (), !*IWorld) | iTask a
replaceTaskInstance instanceNo task iworld=:{options={appVersion},current={taskTime}}
# (meta, iworld) = 'SDS'.read (sdsFocus (instanceNo,False,False,False) taskInstance) 'SDS'.EmptyContext iworld
# (meta, iworld) = 'SDS'.read (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
| isError meta = (liftError meta, iworld)
# meta ='SDS'.directResult (fromOk meta)
= 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> let in 'SDS'.write {TaskMeta|meta & build=appVersion} (sdsFocus (instanceNo,True,True,True) taskInstance) 'SDS'.EmptyContext iworld
= 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> let in 'SDS'.write {TaskMeta|meta & build=appVersion} (sdsFocus (instanceNo,True,True) taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok (), iworld)
deleteTaskInstance :: !InstanceNo !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
......@@ -261,9 +263,9 @@ where
&& maybe True (\(mk,mv) ->
(maybe False ((==) mv) ('DM'.get mk taskAttributes)
|| maybe False ((==) mv) ('DM'.get mk managementAttributes))) onlyAttribute
&& ((includeSessions && instanceType =: (SessionInstance)) ||
(includeDetached && instanceType =: (PersistentInstance _)) ||
(includeStartup && instanceType =: (StartupInstance))
&& ((includeSessions && instanceType =: SessionInstance) ||
(includeDetached && instanceType =: PersistentInstance) ||
(includeStartup && instanceType =: StartupInstance)
)
taskListDynamicValueData :: SDSLens (!TaskId,!TaskId,!TaskListFilter,!ExtendedTaskListFilter) (Map TaskId (TaskValue DeferredJSON)) (Map TaskId (TaskValue DeferredJSON))
......@@ -309,28 +311,17 @@ where
//Filtered views on the instance index
taskInstance :: SDSLens (InstanceNo,Bool,Bool,Bool) TaskMeta TaskMeta
taskInstance :: SDSLens (InstanceNo,Bool,Bool) TaskMeta TaskMeta
taskInstance = sdsLens "taskInstance" param (SDSRead read) (SDSWriteConst write) (SDSNotifyConst notify) Nothing taskListMetaData
where
param (no,includeTaskIO,includeProgress,includeTaskAttributes)
# tfilter = {TaskListFilter|fullTaskListFilter & onlyTaskId = Just [TaskId no 0],includeProgress=includeProgress,includeTaskAttributes=includeTaskAttributes}
param (no,includeTaskIO,includeProgress)
# tfilter = {TaskListFilter|fullTaskListFilter & onlyTaskId = Just [TaskId no 0],includeProgress=includeProgress,includeTaskAttributes=includeProgress}
# efilter = {ExtendedTaskListFilter|fullExtendedTaskListFilter & includeTaskIO=includeTaskIO}
= (TaskId 0 0, TaskId no 0, tfilter,efilter)
read (no,_,_,_) (_,[meta]) = Ok meta
read (no,_,_,_) _ = Error (exception ("Could not find task instance "<+++ no))
write _ data = Ok (Just [data])
notify _ _ _ _ = True
taskInstanceAttributes :: SDSLens InstanceNo (TaskAttributes,TaskAttributes) (TaskAttributes,TaskAttributes)
taskInstanceAttributes = sdsLens "taskInstanceAttributes" param (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) Nothing taskListMetaData
where
param no = (TaskId 0 0, TaskId no 0, {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]},defaultValue)
read no (_,[{TaskMeta|taskAttributes,managementAttributes}]) = Ok (taskAttributes,managementAttributes)
read no _ = Error (exception ("Could not find attributes for task instance "<+++ no))
write no (_,[meta]) (taskAttributes,managementAttributes) = Ok (Just [{TaskMeta|meta & taskAttributes = taskAttributes, managementAttributes = managementAttributes}])
notify no _ _ _ = True
read (no,_,_) (_,[meta]) = Ok meta
read (no,_,_) _ = Error (exception ("Could not find task instance "<+++ no))
write _ data = Ok (Just [data])
notify _ _ _ _ = True
//Last computed value for task instance
taskInstanceValue :: SDSLens InstanceNo (TaskValue DeferredJSON) (TaskValue DeferredJSON)
......@@ -387,9 +378,9 @@ where
write2 _ ws = Ok $ Just ws
toTaskListItem :: !TaskId !TaskMeta -> TaskListItem a
toTaskListItem selfId {TaskMeta|taskId=taskId=:(TaskId instanceNo taskNo),instanceType
toTaskListItem selfId {TaskMeta|taskId=taskId=:(TaskId instanceNo taskNo),detachedFrom
,attachedTo,instanceKey,firstEvent,lastEvent,taskAttributes,managementAttributes}
# listId = case instanceType of (PersistentInstance (Just listId)) = listId ; _ = (TaskId 0 0)
# listId = fromMaybe (TaskId 0 0) detachedFrom
= {TaskListItem|taskId = taskId, listId = listId, detached = taskNo == 0, self = taskId == selfId
,value = NoValue, taskAttributes = 'DM'.union taskAttributes progressAttributes, managementAttributes = managementAttributes}
where
......
......@@ -72,19 +72,15 @@ where
efilter = {ExtendedTaskListFilter|defaultValue & includeSessions = False, includeDetached = True, includeStartup = False}
taskInstanceFromMetaData :: TaskMeta -> TaskInstance
taskInstanceFromMetaData {TaskMeta|taskId=taskId=:(TaskId instanceNo _),instanceType,build,createdAt,status
taskInstanceFromMetaData {TaskMeta|taskId=taskId=:(TaskId instanceNo _),instanceType,build,createdAt,detachedFrom,status
,instanceKey,firstEvent,lastEvent,taskAttributes,managementAttributes}
= {TaskInstance|instanceNo = instanceNo, instanceKey = instanceKey, session = session, listId = listId, build = build
,taskAttributes = taskAttributes, managementAttributes = managementAttributes, value = value
,issuedAt = createdAt, firstEvent = firstEvent, lastEvent = lastEvent}
where
session = (instanceType =: SessionInstance )
listId = case instanceType of
(PersistentInstance (Just listId)) = listId
_ = (TaskId 0 0)
value = case status of
(Left msg) = Exception msg
(Right stable) = if stable Stable Unstable
listId = fromMaybe (TaskId 0 0) detachedFrom
value = either Exception (\stable -> if stable Stable Unstable) status
currentTaskInstanceNo :: SDSSource () InstanceNo ()
currentTaskInstanceNo = createReadOnlySDS (\() iworld=:{current={taskInstance}} -> (taskInstance,iworld))
......
This diff is collapsed.
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