Commit 5ab0e259 authored by Bas Lijnse's avatar Bas Lijnse

Removed instance progress types and sds's

parent 2cd1412f
......@@ -5,6 +5,7 @@ import StdMisc, Data.Tuple, Text, Data.Either, Data.Functor, Data.Func
import iTasks.Internal.SDS
import iTasks.Internal.Serialization
import iTasks.Internal.Store
from iTasks.Internal.TaskState import :: ValueStatus(..)
from StdFunc import seq
import qualified Data.Map as DM
import Data.Map.GenJSON
......@@ -55,7 +56,7 @@ where
notHidden {TaskInstance|attributes} = case 'DM'.get "hidden" attributes of (Just (JSONBool True)) = False ; _ = True
isActive {TaskInstance|value} = value === Unstable
isActive {TaskInstance|value} = value =: Unstable
mkRow {TaskInstance|instanceNo,attributes,listId} =
{WorklistRow
......
......@@ -8,8 +8,7 @@ import Data.Map.GenJSON
import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.Editor.Controls, iTasks.UI.Editor.Modifiers
import iTasks.UI.Layout.Default
from iTasks.WF.Definition import :: InstanceProgress(..)
from iTasks.WF.Combinators.Core import :: TaskListItem(..)
from iTasks.WF.Definition import :: TaskListItem(..)
import iTasks.Extensions.DateTime
import System.Time
......@@ -126,14 +125,14 @@ where
derive class iTask Credentials
currentUser :: SimpleSDSLens User
currentUser = sdsLens "currentUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) Nothing currentTaskInstanceAttributes
currentUser = sdsLens "currentUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotifyConst notify) Nothing currentTaskInstanceAttributes
where
notify _ _ _ = const (const True)
notify _ _ _ _ = False
taskInstanceUser :: SDSLens InstanceNo User User
taskInstanceUser = sdsLens "taskInstanceUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) Nothing taskInstanceAttributesByNo
taskInstanceUser = sdsLens "taskInstanceUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotifyConst notify) Nothing taskInstanceAttributesByNo
where
notify _ _ _ = const (const True)
notify _ _ _ _ = False
userFromAttr :: a TaskAttributes -> MaybeError TaskException User
userFromAttr _ attr = case 'DM'.get "auth-user" attr of
......@@ -176,11 +175,11 @@ forWorker user {TaskListItem|attributes} = case 'DM'.get "user" attributes of
Nothing = True
taskInstancesForUser :: SDSLens User [TaskInstance] ()
taskInstancesForUser = sdsLens "taskInstancesForUser" (const ()) (SDSRead read) (SDSWriteConst write) (SDSNotify notify) Nothing detachedTaskInstances
taskInstancesForUser = sdsLens "taskInstancesForUser" (const ()) (SDSRead read) (SDSWriteConst write) (SDSNotifyConst notify) Nothing detachedTaskInstances
where
read u instances = Ok (filter (forUser u) instances)
write _ () = Ok Nothing
notify _ _ _ = const (const False)
notify _ _ _ _ = False
forUser user {TaskInstance|attributes} = case 'DM'.get "user" attributes of
Just (JSONString uid1) = case user of
......@@ -238,14 +237,13 @@ where
filter = {TaskListFilter|onlySelf=False,onlyTaskId = Nothing, notTaskId=Nothing, onlyIndex = Just [1],onlyAttribute=Nothing
,includeValue=False,includeAttributes=True,includeProgress=True}
toView (_,[{TaskListItem|progress=Just p,attributes}:_]) =
toView (_,[{TaskListItem|value,attributes}:_]) =
{ assignedTo = mkAssignedTo attributes
, firstWorkedOn = fmap (timestampToGmDateTime o timespecToStamp) p.InstanceProgress.firstEvent
, lastWorkedOn = fmap (timestampToGmDateTime o timespecToStamp) p.InstanceProgress.lastEvent
, taskStatus = case p.InstanceProgress.value of
Unstable -> "In progres..."
Stable -> "Task done"
(Exception _) -> "Something went wrong"
, firstWorkedOn = fmap (timestampToGmDateTime o timespecToStamp) (maybe Nothing fromJSON ('DM'.get "firstEvent" attributes))
, lastWorkedOn = fmap (timestampToGmDateTime o timespecToStamp) (maybe Nothing fromJSON ('DM'.get "lastEvent" attributes))
, taskStatus = case value of
(Value _ True) -> "Task done"
_ -> "In progres..."
}
toView (_,[{TaskListItem|attributes}:_]) =
{ assignedTo = mkAssignedTo attributes
......
......@@ -41,10 +41,12 @@ where
//When we run the built-in HTTP server we need to do active garbage collection of instances that were created for sessions
removeOutdatedSessions :: Task ()
removeOutdatedSessions = everyTick \iworld=:{IWorld|options} ->
case read (sdsFocus (TaskId 0 0,TaskId 0 0, defaultValue, {ExtendedTaskListFilter|defaultValue &includeSessions=True}) taskListMetaData) EmptyContext iworld of
case read (sdsFocus (TaskId 0 0,TaskId 0 0, defaultValue, onlySessions) taskListMetaData) EmptyContext iworld of
(Ok (ReadingDone (_,index)), iworld) = checkAll (removeIfOutdated options) index iworld
(Error e, iworld) = (Error e, iworld)
where
onlySessions = {ExtendedTaskListFilter|defaultValue &includeSessions=True,includeDetached=False,includeStartup=False}
checkAll f [] iworld = (Ok (),iworld)
checkAll f [x:xs] iworld = case f x iworld of
(Ok (),iworld) = checkAll f xs iworld
......
......@@ -17,7 +17,7 @@ import iTasks.Internal.SDS
from iTasks.UI.Layout import :: LUI, :: LUIMoves, :: LUIMoveID, :: LUIEffectStage, :: LUINo
from iTasks.Util.DeferredJSON import :: DeferredJSON(..)
from iTasks.Internal.TaskState import :: TaskMeta(..) , :: InstanceType(..), :: TaskChange(..)
from iTasks.Internal.TaskState import :: TaskMeta(..) , :: InstanceType(..), :: TaskChange(..), :: ValueStatus(..)
import iTasks.Internal.TaskEval
from iTasks.SDS.Combinators.Common import toDynamic
......
......@@ -21,7 +21,7 @@ import qualified iTasks.Internal.SDS as SDS
from iTasks.SDS.Combinators.Common import sdsFocus, >*|, mapReadWrite, mapReadWriteError
from StdFunc import const, o
derive gEq TaskMeta, InstanceType, TaskChange
derive gEq TaskMeta, InstanceType, TaskChange, ValueStatus
mkEvalOpts :: TaskEvalOpts
mkEvalOpts =
......@@ -60,14 +60,13 @@ where
# (curReduct, iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceTask) EmptyContext iworld
| isError curReduct = exitWithException instanceNo ((\(Error (e,msg)) -> msg) curReduct) iworld
# curReduct=:(Task eval) = directResult (fromOk curReduct)
//# curReduct=:{TIReduct|task=(Task eval),nextTaskNo=curNextTaskNo,nextTaskTime,tasks} = fromJust curReduct
// Determine the task type (startup,session,local)
# (type,iworld) = determineInstanceType instanceNo iworld
// Determine the progress of the instance
# (nextTaskTime,nextTaskNo,curProgress=:{InstanceProgress|value,attachedTo},iworld) = determineInstanceProgress instanceNo iworld
# (curProgress=:{TaskMeta|nextTaskTime,nextTaskNo,valuestatus,attachedTo},iworld) = determineInstanceProgress instanceNo iworld
//Check exception
| value =: (Exception _)
# (Exception description) = value
| valuestatus =: (Exception _)
# (Exception description) = valuestatus
= exitWithException instanceNo description iworld
//Evaluate instance
# (currentSession,currentAttachment) = case (type,attachedTo) of
......@@ -148,9 +147,8 @@ where
determineInstanceProgress instanceNo iworld
# (meta,iworld) = 'SDS'.read (sdsFocus instanceNo taskInstance) EmptyContext iworld
| isError meta = (1,1,{InstanceProgress|value=Unstable,instanceKey=Nothing,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing},iworld)
# meta=:{TaskMeta|nextTaskNo,nextTaskTime,valuestatus,attachedTo,instanceKey,firstEvent,lastEvent} = directResult (fromOk meta)
= (nextTaskNo,nextTaskTime,{InstanceProgress|value=valuestatus,attachedTo=attachedTo,instanceKey=instanceKey,firstEvent=firstEvent,lastEvent=lastEvent},iworld)
| isError meta = ({defaultValue & nextTaskNo=1, nextTaskTime=1},iworld)
= (directResult (fromOk meta),iworld)
getNextTaskNo iworld=:{IWorld|current={TaskEvalState|nextTaskNo}} = (nextTaskNo,iworld)
......
......@@ -7,7 +7,7 @@ from iTasks.Internal.IWorld import :: IWorld
from iTasks.UI.Definition import :: UIChange
from iTasks.WF.Definition import :: Task, :: TaskResult, :: TaskValue, :: TaskException, :: TaskNo, :: TaskId, :: TaskAttributes, :: TaskEvalOpts, :: Event
from iTasks.SDS.Definition import :: SimpleSDSLens, :: SDSLens, :: SDSSequence
from iTasks.WF.Definition import :: InstanceNo, :: InstanceKey, :: InstanceProgress
from iTasks.WF.Definition import :: InstanceNo, :: InstanceKey
from Data.GenEq import generic gEq
from Data.Error import :: MaybeError
from Data.Map import :: Map
......
......@@ -10,7 +10,7 @@ from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.SDS.Definition import :: SimpleSDSLens, :: SDSLens, :: SDSSequence
from iTasks.Util.DeferredJSON import :: DeferredJSON
from iTasks.WF.Definition import :: Task, :: TaskResult, :: TaskValue, :: TaskException, :: TaskNo, :: TaskId, :: TaskAttributes, :: TaskEvalOpts, :: Event
from iTasks.WF.Definition import :: InstanceNo, :: InstanceKey, :: InstanceProgress, :: ValueStatus
from iTasks.WF.Definition import :: InstanceNo, :: InstanceKey
from iTasks.WF.Definition import class iTask
from iTasks.WF.Combinators.Core import :: AttachmentStatus
from iTasks.WF.Combinators.Core import :: TaskListFilter, :: TaskListItem
......@@ -90,6 +90,8 @@ derive gDefault TaskMeta, ExtendedTaskListFilter
= RemoveTask //Mark for removal from the set on the next evaluation
| ReplaceTask !Dynamic //Replace the task on the next evaluation
:: ValueStatus = Stable | Unstable | Exception !String
//Internally we need more options to filter task list data
:: ExtendedTaskListFilter =
//Extra filter on task type
......@@ -100,6 +102,9 @@ derive gDefault TaskMeta, ExtendedTaskListFilter
, includeTaskReduct :: !Bool
}
//Predefined filters
fullTaskList :: TaskListFilter
mergeTaskAttributes :: !(!TaskAttributes,!TaskAttributes) -> TaskAttributes
//Fresh identifier generation
......@@ -135,7 +140,6 @@ 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 TaskMeta TaskMeta
taskInstanceProgress :: SDSLens InstanceNo InstanceProgress InstanceProgress
taskInstanceAttributes :: SDSLens InstanceNo (TaskAttributes,TaskAttributes) (TaskAttributes,TaskAttributes)
taskInstanceValue :: SDSLens InstanceNo (TaskValue DeferredJSON) (TaskValue DeferredJSON)
......@@ -153,6 +157,9 @@ localShare :: SDSLens TaskId a a | iTask a
parallelTaskList :: SDSLens (!TaskId,!TaskId,!TaskListFilter) (!TaskId,![TaskListItem a]) [(TaskId,TaskAttributes)] | iTask a
topLevelTaskList :: SDSLens TaskListFilter (!TaskId,![TaskListItem a]) [(TaskId,TaskAttributes)] | iTask a
//Conversion to task lists
toTaskListItem :: !TaskId !TaskMeta -> TaskListItem a
//=== Access functions: ===
createClientTaskInstance :: !(Task a) !String !InstanceNo !*IWorld -> *(!MaybeError TaskException TaskId, !*IWorld) | iTask a
......@@ -164,7 +171,6 @@ createSessionTaskInstance :: !(Task a) !TaskAttributes !*IWorld -> (!MaybeError
/**
* Create a stored task instance in the task store (lazily without evaluating it)
* @param The task to store
* @param Whether it is a top-level task
* @param The task evaluation options
* @param The instance number for the task
* @param Management meta data
......@@ -175,7 +181,7 @@ createSessionTaskInstance :: !(Task a) !TaskAttributes !*IWorld -> (!MaybeError
* @return The task id of the stored instance
* @return The IWorld state
*/
createDetachedTaskInstance :: !(Task a) !Bool !TaskEvalOpts !InstanceNo !TaskAttributes !TaskId !Bool !*IWorld -> (!MaybeError TaskException TaskId, !*IWorld) | iTask a
createDetachedTaskInstance :: !(Task a) !TaskEvalOpts !InstanceNo !TaskAttributes !TaskId !Bool !*IWorld -> (!MaybeError TaskException TaskId, !*IWorld) | iTask a
/**
* Replace a stored task instance in the task store.
......
......@@ -48,10 +48,10 @@ from Control.Applicative import class Alternative(<|>)
import Data.GenEq
import qualified Control.Monad
derive JSONEncode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter
derive JSONDecode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter
derive JSONEncode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter, ValueStatus
derive JSONDecode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter, ValueStatus
derive gDefault InstanceProgress, InstanceType, TaskId, ValueStatus, TaskListFilter
derive gDefault InstanceType, TaskId, ValueStatus, TaskListFilter
gDefault{|TaskMeta|}
= {taskId= TaskId 0 0,instanceType=gDefault{|*|},build="",createdAt=gDefault{|*|},nextTaskNo=1,nextTaskTime=1
......@@ -69,6 +69,11 @@ derive gText TaskChange, Set, ExtendedTaskListFilter
instance < TaskMeta where
(<) {TaskMeta|taskId=t1} {TaskMeta|taskId=t2} = t1 < t2
fullTaskList :: TaskListFilter
fullTaskList =
{TaskListFilter|onlyIndex=Nothing,onlyTaskId=Nothing,notTaskId=Nothing,onlyAttribute=Nothing,onlySelf=False
,includeValue=True,includeAttributes=True,includeProgress=True}
mergeTaskAttributes :: !(!TaskAttributes,!TaskAttributes) -> TaskAttributes
mergeTaskAttributes (explicit,implicit) = 'DM'.union explicit implicit
......@@ -145,8 +150,8 @@ createStartupTaskInstance task attributes iworld=:{options={appVersion,autoLayou
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok instanceNo, queueEvent instanceNo ResetEvent iworld)
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=:{options={appVersion,autoLayout},current={taskTime},clock}
createDetachedTaskInstance :: !(Task a) !TaskEvalOpts !InstanceNo !TaskAttributes !TaskId !Bool !*IWorld -> (!MaybeError TaskException TaskId, !*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)
......@@ -275,7 +280,7 @@ taskListTypedValueData = sdsLens "taskListTypedValueData" id (SDSRead read) (SDS
where
read param values = Ok $ fmap decodeTaskValue values
write param updates = Ok $ Just $ encodeTaskValue <$> updates
notify _ _ _ _ = False
notify _ _ _ _ = True
taskListDynamicTaskData :: SDSLens (!TaskId,!TaskId,!TaskListFilter,!ExtendedTaskListFilter) (Map TaskId (Task DeferredJSON)) (Map TaskId (Task DeferredJSON))
taskListDynamicTaskData = sdsLens "taskListDynamicTaskData" param (SDSRead read) (SDSWrite write) (SDSNotify notify) Nothing allTaskReducts
......@@ -296,63 +301,48 @@ taskListTypedTaskData = sdsLens "taskListTypedTaskData" id (SDSRead read) (SDSWr
where
read param tasks = Ok $ fmap (\t -> t @? decodeTaskValue) tasks
write param updates = Ok $ Just $ (\t -> t @? encodeTaskValue) <$> updates
notify _ _ _ _ = False
notify _ _ _ _ = True
//Filtered views on the instance index
taskInstance :: SDSLens InstanceNo TaskMeta TaskMeta
taskInstance = sdsLens "taskInstance" param (SDSRead read) (SDSWriteConst write) (SDSNotifyConst notify) Nothing taskListMetaData
where
param no = (TaskId 0 0, TaskId 0 0, {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]},
param no = (TaskId 0 0, TaskId no 0, {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]},
{ExtendedTaskListFilter|defaultValue & includeSessions=True,includeDetached=True,includeStartup=True})
read no (_,[meta]) = Ok meta
read no _ = Error (exception ("Could not find task instance "<+++ no))
write no data = Ok (Just [data])
notify no _ = const ((==) no)
taskInstanceProgress :: SDSLens InstanceNo InstanceProgress InstanceProgress
taskInstanceProgress = sdsLens "taskInstanceProgress" param (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) Nothing taskListMetaData
where
param no = (TaskId 0 0, TaskId 0 0, {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]},
{ExtendedTaskListFilter|defaultValue & includeSessions=True,includeDetached=True,includeStartup=True})
read no (_,[{TaskMeta|valuestatus,attachedTo,instanceKey,firstEvent,lastEvent}])
= Ok {InstanceProgress|value=valuestatus,attachedTo=attachedTo,instanceKey=instanceKey,firstEvent=firstEvent,lastEvent=lastEvent}
read no _ = Error (exception ("Could not find progress for task instance "<+++ no))
write no (_,[meta]) {InstanceProgress|value,attachedTo,instanceKey,firstEvent,lastEvent}
= Ok (Just [{TaskMeta|meta & valuestatus = value, attachedTo = attachedTo,
instanceKey = instanceKey,firstEvent = firstEvent, lastEvent = lastEvent }])
write no _ _ = Error (exception ("Could not find progress for task instance "<+++ no))
notify no _ = const ((==) no)
notify no _ _ _ = 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 0 0, {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]},defaultValue)
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 _ = const ((==) no)
notify no _ _ _ = True
//Last computed value for task instance
taskInstanceValue :: SDSLens InstanceNo (TaskValue DeferredJSON) (TaskValue DeferredJSON)
taskInstanceValue = sdsLens "taskInstanceValue" param (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) Nothing taskListDynamicValueData
where
param no = (TaskId 0 0, TaskId 0 0, {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]}, defaultValue)
param no = (TaskId 0 0, TaskId no 0, {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]}, defaultValue)
read no values = maybe (Error $ exception ("Could not find value for task instance "<+++ no)) Ok ('DM'.get (TaskId no 0) values)
write no values value = Ok $ Just $ 'DM'.put (TaskId no 0) value values
notify _ _ _ _ = False
notify _ _ _ _ = True
taskInstanceTask :: SDSLens InstanceNo (Task DeferredJSON) (Task DeferredJSON)
taskInstanceTask = sdsLens "taskInstanceTask" param (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) Nothing taskListDynamicTaskData
where
param no = (TaskId 0 0, TaskId 0 0, {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]}, defaultValue)
param no = (TaskId 0 0, TaskId no 0, {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]}, defaultValue)
read no tasks = maybe (Error $ exception ("Could not find task for task instance "<+++ no)) Ok ('DM'.get (TaskId no 0) tasks)
write no tasks task = Ok $ Just $ 'DM'.put (TaskId no 0) task tasks
notify _ _ _ _ = False
notify _ _ _ _ = True
parallelTaskList :: SDSLens (!TaskId,!TaskId,!TaskListFilter) (!TaskId,![TaskListItem a]) [(TaskId,TaskAttributes)] | iTask a
parallelTaskList
......@@ -373,14 +363,7 @@ where
where
itemsMap = 'DM'.fromList [(taskId,meta) \\ meta=:{TaskMeta|taskId} <- items]
notify _ _ _ _ = False
toTaskListItem selfId {TaskMeta|taskId,instanceType,valuestatus,attachedTo,instanceKey,firstEvent,lastEvent,taskAttributes,managementAttributes}
# listId = case instanceType of (PersistentInstance (Just listId)) = listId ; _ = (TaskId 0 0)
= {TaskListItem|taskId = taskId, listId = listId, detached = True, self = taskId == selfId
,value = NoValue, progress = Just progress, attributes = mergeTaskAttributes (taskAttributes,managementAttributes)}
where
progress = {InstanceProgress|value=valuestatus,attachedTo=attachedTo,instanceKey=instanceKey,firstEvent=firstEvent,lastEvent=lastEvent}
notify _ _ _ _ = True
topLevelTaskList :: SDSLens TaskListFilter (!TaskId,![TaskListItem a]) [(TaskId,TaskAttributes)] | iTask a
topLevelTaskList = sdsTranslate "topLevelTaskListWrapper" id
......@@ -396,6 +379,20 @@ where
write1 _ _ = Ok Nothing
write2 _ ws = Ok $ Just ws
toTaskListItem :: !TaskId !TaskMeta -> TaskListItem a
toTaskListItem selfId {TaskMeta|taskId=taskId=:(TaskId instanceNo taskNo),instanceType,valuestatus
,attachedTo,instanceKey,firstEvent,lastEvent,taskAttributes,managementAttributes}
# listId = case instanceType of (PersistentInstance (Just listId)) = listId ; _ = (TaskId 0 0)
= {TaskListItem|taskId = taskId, listId = listId, detached = taskNo == 0, self = taskId == selfId
,value = NoValue, attributes = 'DM'.union (mergeTaskAttributes (taskAttributes,managementAttributes)) progressAttributes}
where
progressAttributes = 'DM'.fromList
[("attachedTo",toJSON attachedTo)
,("instanceKey",toJSON instanceKey)
,("firstEvent",toJSON firstEvent)
,("lastEvent",toJSON lastEvent)
]
taskInstanceParallelTaskList :: SDSLens (TaskId,TaskListFilter) (TaskId,[TaskMeta]) [TaskMeta]
taskInstanceParallelTaskList = sdsTranslate "taskInstanceParallelTaskList" param taskListMetaData
where
......
......@@ -435,8 +435,8 @@ where
verifyInstances instances iworld = foldl verify ([],[],[],iworld) instances
where
verify (active,removed,revoked,iworld) (instanceNo,viewportKey)
= case 'SDS'.read (sdsFocus instanceNo taskInstanceProgress) 'SDS'.EmptyContext iworld of
(Ok (ReadingDone {InstanceProgress|instanceKey=Just key}),iworld)
= case 'SDS'.read (sdsFocus instanceNo taskInstance) 'SDS'.EmptyContext iworld of
(Ok (ReadingDone {TaskMeta|instanceKey=Just key}),iworld)
= if (viewportKey == key)
([(instanceNo,viewportKey):active],removed,revoked,iworld)
(active,removed,[instanceNo:revoked],iworld)
......
......@@ -3,7 +3,7 @@ definition module iTasks.SDS.Combinators.Common
* This module provides common patterns for composing shared sources defined on top of the core set
*/
import iTasks.SDS.Definition
from iTasks.WF.Definition import :: TaskException, :: TaskValue, :: TaskId, :: TaskAttributes, :: InstanceProgress, class iTask
from iTasks.WF.Definition import :: TaskException, :: TaskValue, :: TaskId, :: TaskAttributes, class iTask
from iTasks.WF.Definition import generic gEditor, generic gEq, generic gText, generic JSONEncode, generic JSONDecode
from iTasks.WF.Combinators.Core import :: TaskList, :: TaskListFilter, :: TaskListItem, :: SharedTaskList
from iTasks.Internal.Generic.Visualization import :: TextFormat
......@@ -138,12 +138,6 @@ taskListSelfManagement :: !(SharedTaskList a) -> SimpleSDSLens TaskAttributes |
* The paramater is either the index in the list or a specific task id
*/
taskListItemValue :: !(SharedTaskList a) -> SDSLens (Either Int TaskId) (TaskValue a) () | TC a
/**
* Get the progress of a specific task in the list
* The paramater is either the index in the list or a specific task id
* Note that there is only progress information for detached tasks
*/
taskListItemProgress :: !(SharedTaskList a) -> SDSLens (Either Int TaskId) InstanceProgress () | TC a
/**
* Convenience lens for lookups in Maps. Returns Nothing on a missing key.
......
......@@ -211,16 +211,6 @@ where
vs=:[v:_] = (Ok v)
_ = Error (exception "taskListItemValue: item not found")
taskListItemProgress :: !(SharedTaskList a) -> SDSLens (Either Int TaskId) InstanceProgress () | TC a
taskListItemProgress tasklist = mapReadError read (toReadOnly (sdsTranslate "taskListItemProgress" listFilter tasklist))
where
listFilter (Left index) = {onlyIndex=Just [index],onlyTaskId=Nothing,notTaskId=Nothing,onlySelf=False,onlyAttribute=Nothing,includeValue=False,includeAttributes=False,includeProgress=True}
listFilter (Right taskId) = {onlyIndex=Nothing,onlyTaskId=Just [taskId],notTaskId=Nothing,onlySelf=False,onlyAttribute=Nothing,includeValue=False,includeAttributes=False,includeProgress=True}
read (_,items) = case [p \\ {TaskListItem|progress=Just p} <- items] of
[p:_] = Ok p
_ = Error (exception "taskListItemProgress: item not found")
mapMaybeLens :: !String !(Shared sds (Map a b)) -> SDSLens a (Maybe b) b | < a & == a & TC a & TC b & RWShared sds
mapMaybeLens name origShare = sdsLens name (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just reducer) origShare
where
......
......@@ -4,7 +4,7 @@ definition module iTasks.SDS.Sources.System
*/
import iTasks.SDS.Definition
from iTasks.WF.Definition import :: TaskId, :: TaskNo, :: InstanceNo, :: InstanceKey, :: TaskAttributes, :: ValueStatus
from iTasks.WF.Definition import :: TaskId, :: TaskNo, :: InstanceNo, :: InstanceKey, :: TaskAttributes
from iTasks.WF.Combinators.Core import :: TaskList, :: SharedTaskList, :: TaskListFilter, :: TaskListItem
from iTasks.Extensions.DateTime import :: DateTime, :: Date, :: Time
from iTasks.Engine import :: EngineOptions
......@@ -14,6 +14,8 @@ from System.FilePath import :: FilePath
from Data.Map import :: Map
from Data.Maybe import :: Maybe
from iTasks.Internal.TaskState import :: ValueStatus //FIXME Don't import internal types
//* Types to view the server's internal table of running task instances
:: TaskInstance =
{ instanceNo :: !InstanceNo //* Unique global identification
......@@ -54,10 +56,10 @@ currentTopTask :: SDSLens () TaskId ()
//Task instances
currentTaskInstanceNo :: SDSSource () InstanceNo ()
currentTaskInstanceAttributes :: SDSSequence () TaskAttributes TaskAttributes
allTaskInstances :: SDSLens () [TaskInstance] ()
detachedTaskInstances :: SDSLens () [TaskInstance] () //Exclude sessions
taskInstanceByNo :: SDSLens InstanceNo TaskInstance TaskAttributes
taskInstanceAttributesByNo :: SDSLens InstanceNo TaskAttributes TaskAttributes
allTaskInstances :: SDSSequence () [TaskInstance] ()
detachedTaskInstances :: SDSSequence () [TaskInstance] () //Exclude sessions
taskInstanceByNo :: SDSSequence InstanceNo TaskInstance TaskAttributes
taskInstanceAttributesByNo :: SDSSequence InstanceNo TaskAttributes TaskAttributes
taskInstancesByAttribute :: SDSLens (!String,!JSONNode) [TaskInstance] () //Parameter is (key,value)
// Application
......
......@@ -3,8 +3,9 @@ implementation module iTasks.SDS.Sources.System
import iTasks.SDS.Definition
import iTasks.SDS.Combinators.Core
import iTasks.SDS.Combinators.Common
import iTasks.Extensions.DateTime
import iTasks.Extensions.DateTime //FIXME: Extensions should not be part of core
import System.Time
import Data.Func, Data.Either
import iTasks.Engine
import iTasks.Internal.SDS
......@@ -72,14 +73,6 @@ where
param = (TaskId 0 0,self,defaultValue,efilter)
efilter = {ExtendedTaskListFilter|defaultValue & includeSessions = False, includeDetached = True, includeStartup = False}
toTaskListItem :: !TaskId !TaskMeta -> TaskListItem a
toTaskListItem selfId {TaskMeta|taskId,instanceType,valuestatus,attachedTo,instanceKey,firstEvent,lastEvent,taskAttributes,managementAttributes}
# listId = case instanceType of (PersistentInstance (Just listId)) = listId ; _ = (TaskId 0 0)
= {TaskListItem|taskId = taskId, listId = listId, detached = True, self = taskId == selfId
,value = NoValue, progress = Just progress, attributes = mergeTaskAttributes (taskAttributes,managementAttributes)}
where
progress = {InstanceProgress|value=valuestatus,attachedTo=attachedTo,instanceKey=instanceKey,firstEvent=firstEvent,lastEvent=lastEvent}
taskInstanceFromMetaData :: TaskMeta -> TaskInstance
taskInstanceFromMetaData {TaskMeta|taskId=taskId=:(TaskId instanceNo _),instanceType,build,createdAt,valuestatus,instanceKey,firstEvent,lastEvent,taskAttributes,managementAttributes}
# session = (instanceType =: SessionInstance )
......@@ -93,66 +86,61 @@ currentTaskInstanceNo :: SDSSource () InstanceNo ()
currentTaskInstanceNo = createReadOnlySDS (\() iworld=:{current={taskInstance}} -> (taskInstance,iworld))
currentTaskInstanceAttributes :: SDSSequence () TaskAttributes TaskAttributes
currentTaskInstanceAttributes
= sdsSequence "currentTaskInstanceAttributes"
id
(\_ no -> no)
(\_ _ -> Right snd)
(SDSWriteConst (\_ _ -> Ok Nothing))
(SDSWrite (\no r w -> (Ok (Just w))))
currentTaskInstanceNo
taskInstanceAttributesByNo
allTaskInstances :: SDSLens () [TaskInstance] ()
allTaskInstances
= (sdsProject (SDSLensRead readInstances) (SDSBlindWrite \_. Ok Nothing) Nothing
(sdsFocus param taskListMetaData))
currentTaskInstanceAttributes= sdsSequence "currentTaskInstanceAttributes" param1 param2 read (SDSWriteConst write1) (SDSWrite write2) currentTaskInstanceNo taskListMetaData
where
self = TaskId 0 0
param = (TaskId 0 0,self,defaultValue,defaultValue)
param1 _ = ()
param2 _ selfNo = (TaskId 0 0, TaskId selfNo 0, tfilter selfNo, defaultValue)
where
tfilter no = {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]}
readInstances (_,is) = Ok (map taskInstanceFromMetaData is)
read no selfNo = Right $ \(_,(_,[{TaskMeta|taskAttributes,managementAttributes}])) -> mergeTaskAttributes (taskAttributes,managementAttributes)
write1 _ _ = Ok Nothing
write2 _ (_,[meta]) update = Ok $ Just $ [{TaskMeta|meta & managementAttributes = 'DM'.union update meta.TaskMeta.managementAttributes}]
detachedTaskInstances :: SDSLens () [TaskInstance] ()
detachedTaskInstances
= (sdsProject (SDSLensRead readInstances) (SDSBlindWrite \_. Ok Nothing) Nothing
(sdsFocus param taskListMetaData))
allTaskInstances :: SDSSequence () [TaskInstance] ()
allTaskInstances= sdsSequence "allTaskInstances" param1 param2 read (SDSWriteConst write1) (SDSWriteConst write2) currentTaskInstanceNo taskListMetaData
where
self = TaskId 0 0
param = (TaskId 0 0,self,defaultValue,efilter)
efilter = {ExtendedTaskListFilter|defaultValue & includeSessions = False, includeDetached = True, includeStartup = False}
readInstances (_,is) = Ok (map taskInstanceFromMetaData is)
taskInstanceByNo :: SDSLens InstanceNo TaskInstance TaskAttributes
taskInstanceByNo
= sdsProject (SDSLensRead readItem) (SDSLensWrite writeItem) Nothing
(sdsTranslate "taskInstanceByNo" param taskListMetaData)
param1 _ = ()
param2 _ selfNo = (TaskId 0 0,TaskId selfNo 0,fullTaskList,defaultValue)
read _ selfNo = Right $ \(_,(_,meta)) -> map taskInstanceFromMetaData meta
write1 _ _ = Ok Nothing
write2 _ _ = Ok Nothing
detachedTaskInstances :: SDSSequence () [TaskInstance] ()
detachedTaskInstances = sdsSequence "detachedTaskInstances" param1 param2 read (SDSWriteConst write1) (SDSWriteConst write2) currentTaskInstanceNo taskListMetaData
where
self = TaskId 0 0
param no = (TaskId 0 0,self,tfilter no,defaultValue)
tfilter no = {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]}
param1 _ = ()
param2 _ selfNo = (TaskId 0 0,TaskId selfNo 0,fullTaskList,efilter)
where
efilter = {ExtendedTaskListFilter|defaultValue & includeSessions = False, includeDetached = True, includeStartup = False}
read _ selfNo = Right $ \(_,(_,meta)) -> map taskInstanceFromMetaData meta
readItem (_,[i]) = Ok (taskInstanceFromMetaData i)
readItem _ = Error (exception "Task instance not found")
write1 _ _ = Ok Nothing
write2 _ _ = Ok Nothing
writeItem (_,[meta]) new = Ok (Just [{TaskMeta|meta & managementAttributes = 'DM'.union new meta.TaskMeta.managementAttributes}])
writeItem _ _ = Error (exception "Task instance not found")
taskInstanceAttributesByNo :: SDSLens InstanceNo TaskAttributes TaskAttributes
taskInstanceAttributesByNo
= sdsProject (SDSLensRead readItem) (SDSLensWrite writeItem) Nothing
(sdsTranslate "taskInstanceAttributesByNo" param taskListMetaData)
taskInstanceByNo :: SDSSequence InstanceNo TaskInstance TaskAttributes
taskInstanceByNo = sdsSequence "taskInstanceByNo" param1 param2 read (SDSWriteConst write1) (SDSWrite write2) currentTaskInstanceNo taskListMetaData
where
self = TaskId 0 0
param no = (TaskId 0 0,self,tfilter no,defaultValue)
tfilter no = {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]}
param1 _ = ()
param2 no selfNo = (TaskId 0 0, TaskId selfNo 0, tfilter no, defaultValue)
where
tfilter no = {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]}
readItem (_,[{TaskMeta|taskAttributes,managementAttributes}]) = Ok (mergeTaskAttributes (taskAttributes,managementAttributes))
readItem _ = Error (exception "Task instance not found")
read no selfNo = Right $ \(_,(_,[meta])) -> taskInstanceFromMetaData meta
write1 _ _ = Ok Nothing
write2 no (_,[meta]) update = Ok $ Just $ [{TaskMeta|meta & managementAttributes = 'DM'.union update meta.TaskMeta.managementAttributes}]
writeItem (_,[meta]) new = Ok (Just [{TaskMeta|meta & managementAttributes = 'DM'.union new meta.TaskMeta.managementAttributes}])
writeItem _ _ = Error (exception "Task instance not found")
taskInstanceAttributesByNo :: SDSSequence InstanceNo TaskAttributes TaskAttributes
taskInstanceAttributesByNo = sdsSequence "taskInstanceAttributesByNo" param1 param2 read (SDSWriteConst write1) (SDSWrite write2) currentTaskInstanceNo taskListMetaData
where
param1 _ = ()
param2 no selfNo = (TaskId 0 0, TaskId selfNo 0, tfilter no, defaultValue)
where
tfilter no = {TaskListFilter|defaultValue & onlyTaskId = Just [TaskId no 0]}
read no selfNo = Right $ \(_,(_,[{TaskMeta|taskAttributes,managementAttributes}])) -> mergeTaskAttributes (taskAttributes,managementAttributes)
write1 _ _ = Ok Nothing
write2 no (_,[meta]) update = Ok $ Just $ [{TaskMeta|meta & managementAttributes = 'DM'.union update meta.TaskMeta.managementAttributes}]
taskInstancesByAttribute :: SDSLens (!String,!JSONNode) [TaskInstance] ()
taskInstancesByAttribute
......
......@@ -332,12 +332,13 @@ where
# task = parTask (sdsTranslate "setTaskAndList" (\listFilter -> (listId,taskId,listFilter)) parallelTaskList)
= (Ok (taskId, Just (taskId,task)), iworld)
mkDetached evalDirect managementAttr iworld
//We need to know the instance number in advance, so we can pass the correctly focused task list share
//to the detached parallel task
# (mbInstanceNo,iworld) = newInstanceNo iworld
= case mbInstanceNo of
Ok instanceNo
# isTopLevel = listId == TaskId 0 0
# listShare = if isTopLevel topLevelTaskList (sdsTranslate "setTaskAndList" (\listFilter -> (listId,TaskId instanceNo 0, listFilter)) parallelTaskList)
# (mbTaskId,iworld) = createDetachedTaskInstance (parTask listShare) isTopLevel evalOpts instanceNo managementAttr listId evalDirect iworld
# listShare = sdsTranslate "setTaskAndList" (\listFilter -> (listId, TaskId instanceNo 0, listFilter)) parallelTaskList
# (mbTaskId,iworld) = createDetachedTaskInstance (parTask listShare) evalOpts instanceNo managementAttr listId evalDirect iworld
= case mbTaskId of
Ok taskId = (Ok (taskId, Nothing), iworld)
err = (liftError err, iworld)
......@@ -637,8 +638,7 @@ where
//TODO: Make sure we don't lose the attributes!