Commit e5d60869 authored by Bas Lijnse's avatar Bas Lijnse

Merge branch '342-tuning-task-attributes' into 308-make-use-of-active-tab-information

parents 92a7de46 1a57bf8e
......@@ -54,33 +54,33 @@ actionStatusByNo :: SDSLens InstanceNo ActionStatus ActionStatus
actionStatusByNo = sdsProject (SDSLensRead read) (SDSLensWrite write) Nothing taskInstanceByNo
where
read item = Ok (thd3 (toActionStatus item))
write {TaskInstance|attributes} status = Ok (Just (fromActionStatus status attributes))
write {TaskInstance|managementAttributes} status = Ok (Just (fromActionStatus status managementAttributes))
numActionsByContact :: SDSLens ContactNo Int ()
numActionsByContact = mapRead length actionStatusesByContact
toActionStatuses :: [TaskInstance] -> [(InstanceNo,InstanceNo,ActionStatus)]
toActionStatuses items = (map toActionStatus items)
toActionStatuses items = map toActionStatus items
toActionStatusesTL :: [TaskListItem a] -> [(InstanceNo,InstanceNo,ActionStatus)]
toActionStatusesTL items = [toActionStatusTL i \\ i=:{TaskListItem|progress=Just _} <- items]
toActionStatusesTL items = map toActionStatusTL items
toActionStatus :: TaskInstance -> (InstanceNo,InstanceNo,ActionStatus)
toActionStatus {TaskInstance|instanceNo=tNo,listId=(TaskId lNo _),attributes}
# title = maybe "-" (\(JSONString s) -> s) ('DM'.get "title" attributes)
# description = fmap (\(JSONString s) -> s) ('DM'.get "description" attributes)
# progress = fromMaybe ActionActive (maybe Nothing fromJSON ('DM'.get "action-progress" attributes))
# incidents = fromMaybe [] (maybe Nothing fromJSON ('DM'.get "action-incidents" attributes))
# contacts = fromMaybe [] (maybe Nothing fromJSON ('DM'.get "action-contacts" attributes))
toActionStatus {TaskInstance|instanceNo=tNo,listId=(TaskId lNo _),managementAttributes}
# title = maybe "-" (\(JSONString s) -> s) ('DM'.get "title" managementAttributes)
# description = fmap (\(JSONString s) -> s) ('DM'.get "description" managementAttributes)
# progress = fromMaybe ActionActive (maybe Nothing fromJSON ('DM'.get "action-progress" managementAttributes))
# incidents = fromMaybe [] (maybe Nothing fromJSON ('DM'.get "action-incidents" managementAttributes))
# contacts = fromMaybe [] (maybe Nothing fromJSON ('DM'.get "action-contacts" managementAttributes))
= (tNo,lNo,{ActionStatus|title=title,description=description,progress=progress,incidents=incidents,contacts=contacts})
toActionStatusTL :: (TaskListItem a) -> (InstanceNo,InstanceNo,ActionStatus)
toActionStatusTL {TaskListItem|taskId=(TaskId tNo _),listId=(TaskId lNo _),attributes}
# title = maybe "-" (\(JSONString s) -> s) ('DM'.get "title" attributes)
# description = fmap (\(JSONString s) -> s) ('DM'.get "description" attributes)
# progress = fromMaybe ActionActive (maybe Nothing fromJSON ('DM'.get "action-progress" attributes))
# incidents = fromMaybe [] (maybe Nothing fromJSON ('DM'.get "action-incidents" attributes))
# contacts = fromMaybe [] (maybe Nothing fromJSON ('DM'.get "action-contacts" attributes))
toActionStatusTL {TaskListItem|taskId=(TaskId tNo _),listId=(TaskId lNo _),managementAttributes}
# title = maybe "-" (\(JSONString s) -> s) ('DM'.get "title" managementAttributes)
# description = fmap (\(JSONString s) -> s) ('DM'.get "description" managementAttributes)
# progress = fromMaybe ActionActive (maybe Nothing fromJSON ('DM'.get "action-progress" managementAttributes))
# incidents = fromMaybe [] (maybe Nothing fromJSON ('DM'.get "action-incidents" managementAttributes))
# contacts = fromMaybe [] (maybe Nothing fromJSON ('DM'.get "action-contacts" managementAttributes))
= (tNo,lNo,{ActionStatus|title=title,description=description,progress=progress,incidents=incidents,contacts=contacts})
fromActionStatus :: ActionStatus TaskAttributes -> TaskAttributes
......@@ -99,14 +99,13 @@ toSelfActionStatus (_,items) = case [i \\ i=:{TaskListItem|taskId,self} <- items
fromSelfActionStatus :: ActionStatus (TaskList a) -> MaybeError TaskException (Maybe [(TaskId,TaskAttributes)])
fromSelfActionStatus status (_,items) = case [i \\ i=:{TaskListItem|taskId,self} <- items | self] of
[{TaskListItem|taskId,attributes}:_] = Ok (Just [(taskId,fromActionStatus status attributes)])
_ = Error (exception "Task id not found in self management share")
[{TaskListItem|taskId,managementAttributes}:_] = Ok (Just [(taskId,fromActionStatus status managementAttributes)])
_ = Error (exception "Task id not found in self management share")
selfActionStatus :: (SharedTaskList a) -> SimpleSDSLens ActionStatus | iTask a
selfActionStatus list = sdsFocus taskListFilter (mapReadWriteError (toSelfActionStatus,fromSelfActionStatus) Nothing list)
where
taskListFilter = {TaskListFilter|onlyIndex=Nothing,onlyTaskId=Nothing,onlySelf=False
,includeValue=False,includeAttributes=True,includeProgress=False}
taskListFilter = {TaskListFilter|fullTaskListFilter & includeManagementAttributes=True}
actionItemStatistics :: [ActionStatus] -> ActionStatistics
actionItemStatistics items = foldr count {numPlanned=0,numActive=0,numCompleted=0,numFailed=0,numCanceled=0} items
......@@ -592,7 +591,7 @@ where
//Look in action the catalog for an entry that has the identity
findReplacement taskId
= get (sdsFocus taskId (taskListEntryMeta topLevelTasks) |*| actionCatalog)
@ \(taskListEntry,catalog) -> maybe Nothing (lookup catalog) ('DM'.get "actionitem-identity" taskListEntry.TaskListItem.attributes)
@ \(taskListEntry,catalog) -> maybe Nothing (lookup catalog) ('DM'.get "actionitem-identity" taskListEntry.TaskListItem.managementAttributes)
where
lookup [] match = Nothing
lookup [{CatalogAction|identity,tasks}:cfs] match = if ((JSONString identity) == match) (Just tasks) (lookup cfs match)
......
......@@ -199,7 +199,7 @@ where
taskPid = mapRead find (sdsFocus ("name",JSONString identity) taskInstancesByAttribute)
where
find instances = case [(instanceNo,value) \\ {TaskInstance|instanceNo,value,attributes} <- instances | hasName identity attributes] of
find instances = case [(instanceNo,value) \\ {TaskInstance|instanceNo,value,taskAttributes} <- instances | hasName identity taskAttributes] of
[(i,v):_] = Just (TaskId i 0,v)
_ = Nothing
......
......@@ -17,8 +17,8 @@ addOnceToWorkspace identity task workspace
_ = return ()
where
find identity [] = Nothing
find identity [p=:{TaskListItem|taskId,attributes}:ps]
| maybe False ((==) (JSONString identity)) ('DM'.get "name" attributes) = Just taskId
= find identity ps
find identity [p=:{TaskListItem|taskId,taskAttributes}:ps]
| maybe False ((==) (JSONString identity)) ('DM'.get "name" taskAttributes) = Just taskId
= find identity ps
removeWhenStable t l = t >>* [OnValue (ifStable (\_ -> get (taskListSelfId l) >>- \id -> removeTask id l @? const NoValue))]
......@@ -25,7 +25,6 @@ derive class iTask ObjectType, ActorStatus, Availability, ActorHealth, ActorEner
derive class iTask Cable, Priority, Network, Device, CableType, DeviceKind, CommandAim, Capability, CapabilityExpr
derive gEditor Set
derive gDefault Set
derive gText Set
derive JSONEncode Set
derive JSONDecode Set
......
......@@ -154,29 +154,28 @@ viewNotifications = viewSharedInformation [ViewAs (join ", ")] currentNotificati
tasksToDo :: SDSLens () [(TaskId, WorklistRow)] ()
tasksToDo = taskForCurrentUser isToDo
where
isToDo {TaskListItem|attributes} = fmap (\(JSONInt x) -> x == toInt Immediate) ('DM'.get "priority" attributes) == Just True
isToDo {TaskListItem|managementAttributes} = fmap (\(JSONInt x) -> x == toInt Immediate) ('DM'.get "priority" managementAttributes) == Just True
incomingTasks :: SDSLens () [(TaskId, WorklistRow)] ()
incomingTasks = taskForCurrentUser isIncoming
where
isIncoming {TaskListItem|attributes} = fmap (\(JSONInt x) -> x /= toInt Immediate) ('DM'.get "priority" attributes) == Just True
isIncoming {TaskListItem|managementAttributes} = fmap (\(JSONInt x) -> x /= toInt Immediate) ('DM'.get "priority" managementAttributes) == Just True
taskForCurrentUser f = toReadOnly (mapRead (\(procs, ownPid) -> [(p.TaskListItem.taskId, mkRow p) \\ p <- procs | show ownPid p && isActive p && f p]) (processesForCurrentUser |*| currentTopTask))
show ownPid {TaskListItem|taskId,progress=Just _} = taskId /= ownPid
show ownPid _ = False
show ownPid {TaskListItem|taskId} = taskId /= ownPid
isActive {TaskListItem|progress=Just {InstanceProgress|value}} = value === Unstable
isActive {TaskListItem|value} = value =: (Value _ False)
mkRow {TaskListItem|taskId,attributes} =
mkRow {TaskListItem|taskId,managementAttributes} =
{ WorklistRow
| taskNr = Just (toString taskId)
, title = fmap toString ('DM'.get "title" attributes)
, priority = fmap toString ('DM'.get "priority" attributes)
, createdBy = fmap toString ('DM'.get "createdBy" attributes)
, date = fmap toString ('DM'.get "createdAt" attributes)
, deadline = fmap toString ('DM'.get "completeBefore" attributes)
, createdFor = fmap toString ('DM'.get "createdFor" attributes)
, title = fmap toString ('DM'.get "title" managementAttributes)
, priority = fmap toString ('DM'.get "priority" managementAttributes)
, createdBy = fmap toString ('DM'.get "createdBy" managementAttributes)
, date = fmap toString ('DM'.get "createdAt" managementAttributes)
, deadline = fmap toString ('DM'.get "completeBefore" managementAttributes)
, createdFor = fmap toString ('DM'.get "createdFor" managementAttributes)
, parentTask = Nothing
}
......@@ -17,8 +17,8 @@ addOnceToWorkspace identity task workspace
_ = return ()
find identity [] = Nothing
find identity [p=:{TaskListItem|taskId,attributes}:ps]
| maybe False ((==) (JSONString identity)) ('DM'.get "name" attributes) = Just taskId
find identity [p=:{TaskListItem|taskId,taskAttributes}:ps]
| maybe False ((==) (JSONString identity)) ('DM'.get "name" taskAttributes) = Just taskId
= find identity ps
removeWhenStable t l = t >>* [OnValue (ifStable (\_ -> get (taskListSelfId l) >>- \id -> removeTask id l @? const NoValue))]
......@@ -29,9 +29,9 @@ removeFromWorkspace identity workspace
>>- \items -> case find identity items of
Nothing = return ()
where names = map getName items
getName {TaskListItem|taskId,attributes} | isJust mbname = let (Just (JSONString name)) = mbname in name
getName {TaskListItem|taskId,taskAttributes} | isJust mbname = let (Just (JSONString name)) = mbname in name
| otherwise = "noname"
where mbname = 'DM'.get "name" attributes
where mbname = 'DM'.get "name" taskAttributes
appstr [] = ""
appstr [e:es] = e +++ " " +++ appstr es
(Just taskId) = removeTask taskId workspace @! ()
......@@ -12,6 +12,11 @@ import C2.Apps.ShipAdventure.Types
import Data.Map.GenJSON
import Data.Functor
derive gEditor Set
derive gText Set
derive JSONEncode Set
derive JSONDecode Set
dOffRegisterEntity :: [User -> Task Entity]
dOffRegisterEntity = []
......@@ -56,12 +61,6 @@ damagePrediction
resetSections = set 'DS'.newSet disabledSections >>| damagePrediction
isDisabled c3d disSects = 'DS'.member c3d disSects
derive gEditor Set
derive gDefault Set
derive gText Set
derive JSONEncode Set
derive JSONDecode Set
showCommandAims :: Task ()
showCommandAims = Hint "Current Command Aims" @>> viewSharedInformation [] commandAims @! ()
......
......@@ -53,11 +53,11 @@ where
notSelf ownPid {TaskInstance|instanceNo} = (TaskId instanceNo 0) <> ownPid
notSelf ownPid _ = False
notHidden {TaskInstance|attributes} = case 'DM'.get "hidden" attributes of (Just (JSONBool True)) = False ; _ = True
notHidden {TaskInstance|managementAttributes} = case 'DM'.get "hidden" managementAttributes of (Just (JSONBool True)) = False ; _ = True
isActive {TaskInstance|value} = value === Unstable
isActive {TaskInstance|value} = value =: Unstable
mkRow {TaskInstance|instanceNo,attributes,listId} =
mkRow {TaskInstance|instanceNo,taskAttributes,managementAttributes,listId} =
{WorklistRow
|taskNr = Just (toString instanceNo)
,title = fmap (\(JSONString x) -> x) ('DM'.get "title" attributes)
......@@ -68,6 +68,8 @@ where
,createdFor = fmap (toString o toUserConstraint) ('DM'.get "createdFor" attributes)
,parentTask = if (listId == TaskId 0 0) Nothing (Just (toString listId))
}
where
attributes = 'DM'.union managementAttributes taskAttributes
//Fix Overloading
toUserConstraint :: JSONNode -> UserConstraint
......@@ -200,8 +202,8 @@ where
= get currentUser @ userRoles
>>- \roles ->
forever
( enterChoiceWithSharedAs [ChooseFromGrid snd] (worklist roles) (appSnd (\{WorklistRow|parentTask} -> isNothing parentTask))
>>* (continuations roles taskList)
( enterChoiceWithSharedAs [ChooseFromGrid snd] (worklist roles) (appSnd (\{WorklistRow|parentTask} -> isNothing parentTask))
>>* continuations roles taskList
)
worklist roles = if (isMember "admin" roles) allWork myWork
......@@ -330,7 +332,7 @@ where
//the 'catalogId' that is stored in the incompatible task instance's properties
findReplacement taskId
= get ((sdsFocus taskId (taskListEntryMeta topLevelTasks)) |*| workflows)
@ \(taskListEntry,catalog) -> maybe Nothing (lookup catalog) ('DM'.get "catalogId" taskListEntry.TaskListItem.attributes)
@ \(taskListEntry,catalog) -> maybe Nothing (lookup catalog) ('DM'.get "catalogId" taskListEntry.TaskListItem.managementAttributes)
where
lookup [wf=:{Workflow|path}:wfs] (JSONString cid) = if (path == cid) (Just wf) (lookup wfs (JSONString cid))
lookup [] _ = Nothing
......@@ -343,8 +345,8 @@ appendOnce identity task slist
(appendTask Embedded (removeWhenStable (task <<@ ("name", JSONString name) <<@ ("order", JSONInt (maxOrder items + 1)))) slist @! ())
where
name = toString identity
maxOrder items = foldr max 0 [maybe 0 (\(JSONInt i) -> i) ('DM'.get "order" attributes) \\ {TaskListItem|attributes} <- items]
hasName name {TaskListItem|attributes} = maybe False ((==) (JSONString name)) ('DM'.get "name" attributes)
maxOrder items = foldr max 0 [maybe 0 (\(JSONInt i) -> i) ('DM'.get "order" taskAttributes) \\ {TaskListItem|taskAttributes} <- items]
hasName name {TaskListItem|taskAttributes} = maybe False ((==) (JSONString name)) ('DM'.get "name" taskAttributes)
checkItems name [] = False
checkItems name [i:is] = hasName name i || checkItems name is
......
......@@ -35,12 +35,12 @@ where
# (uiForOldP, _, _) = fromOk uiForOldP
# (uiForNewP, vst) = (dynamicCompoundEditor $ editor p).CompoundEditor.genUI 'Map'.newMap dp (Update new) vst
| isError uiForNewP = (liftError uiForNewP, vst)
# (uiForNewP, st, childSts) = fromOk uiForNewP
# (uiForNewP, newSt, newChildSts) = fromOk uiForNewP
| uiForOldP === uiForNewP =
appFst
(fmap $ appSnd3 \st -> (p, st))
((dynamicCompoundEditor $ editor p).CompoundEditor.onRefresh dp new mbSt childSts vst)
| otherwise = (Ok (ReplaceUI uiForNewP, (p, st), childSts), vst)
| otherwise = (Ok (ReplaceUI uiForNewP, (p, newSt), newChildSts), vst)
valueFromState (p, st) childSts
= (\val -> (p, val)) <$> (dynamicCompoundEditor $ editor p).CompoundEditor.valueFromState st childSts
......
implementation module iTasks.Extensions.JSONFile
import StdBool, StdList, StdFile, StdArray, System.FilePath, System.File, Data.Error, Text.GenJSON, StdString
import iTasks.Internal.IWorld, iTasks.Internal.Task, iTasks.Internal.TaskState, iTasks.Extensions.Document
import iTasks.Internal.IWorld, iTasks.Internal.Task, iTasks.Internal.TaskState
import iTasks.Extensions.Document
:: JSONParseException = CannotParse !String
instance toString JSONParseException
......
implementation module iTasks.Extensions.TextFile
import StdBool, StdList, StdFile, StdArray, System.FilePath, Text, System.File, Data.Error, StdString
import iTasks.Internal.IWorld, iTasks.Internal.Task, iTasks.Internal.TaskState, iTasks.Internal.TaskState, iTasks.Extensions.Document
import iTasks.Internal.IWorld, iTasks.Internal.Task, iTasks.Internal.TaskState
import iTasks.Extensions.Document
CHUNK_SIZE :== 1048576 // 1M
......
......@@ -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(..), fullTaskListFilter
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
......@@ -165,24 +164,24 @@ processesForCurrentUser = mapRead readPrj ((currentProcesses >*| currentUser))
where
readPrj (items,user) = filter (forWorker user) items
forWorker user {TaskListItem|attributes} = case 'DM'.get "user" attributes of
forWorker user {TaskListItem|managementAttributes} = case 'DM'.get "user" managementAttributes of
Just (JSONString uid1) = case user of
(AuthenticatedUser uid2 _ _) = uid1 == uid2
_ = False
Nothing = case 'DM'.get "role" attributes of
Nothing = case 'DM'.get "role" managementAttributes of
Just (JSONString role) = case user of
(AuthenticatedUser _ roles _) = isMember role roles
_ = False
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
forUser user {TaskInstance|taskAttributes,managementAttributes} = case 'DM'.get "user" attributes of
Just (JSONString uid1) = case user of
(AuthenticatedUser uid2 _ _) = uid1 == uid2
_ = False
......@@ -192,6 +191,8 @@ where
(AuthenticatedUser _ roles _) = isMember role roles
_ = False
Nothing = True
where
attributes = 'DM'.union managementAttributes taskAttributes
taskInstancesForCurrentUser :: SDSSequence () [TaskInstance] ()
taskInstancesForCurrentUser
......@@ -235,20 +236,18 @@ where
processControl tlist
= viewSharedInformation [ViewAs toView] (sdsFocus filter tlist) @? const NoValue
where
filter = {TaskListFilter|onlySelf=False,onlyTaskId = Nothing, onlyIndex = Just [1]
,includeValue=False,includeAttributes=True,includeProgress=True}
toView (_,[{TaskListItem|progress=Just p,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"
filter = {TaskListFilter|fullTaskListFilter & onlyIndex =Just [1], includeProgress=True}
toView (_,[{TaskListItem|value,taskAttributes,managementAttributes}:_]) =
{ assignedTo = mkAssignedTo managementAttributes
, firstWorkedOn = fmap (timestampToGmDateTime o timespecToStamp) (maybe Nothing fromJSON ('DM'.get "firstEvent" taskAttributes))
, lastWorkedOn = fmap (timestampToGmDateTime o timespecToStamp) (maybe Nothing fromJSON ('DM'.get "lastEvent" taskAttributes))
, taskStatus = case value of
(Value _ True) -> "Task done"
_ -> "In progres..."
}
toView (_,[{TaskListItem|attributes}:_]) =
{ assignedTo = mkAssignedTo attributes
toView (_,[{TaskListItem|managementAttributes}:_]) =
{ assignedTo = mkAssignedTo managementAttributes
, firstWorkedOn = Nothing
, lastWorkedOn = Nothing
, taskStatus = "No progress"
......
......@@ -608,7 +608,9 @@ getTaskIdByAttribute key value = get attrb
where
attrb = mapRead find (sdsFocus (key,value) taskInstancesByAttribute)
find instances = case [instanceNo \\ {TaskInstance|instanceNo,attributes} <- instances | hasValue key value attributes] of
find instances
= case [instanceNo \\ {TaskInstance|instanceNo,taskAttributes,managementAttributes}
<- instances | hasValue key value ('DM'.union managementAttributes taskAttributes)] of
[i:_] = Just i
_ = Nothing
......
......@@ -17,6 +17,10 @@ import Text
from Data.Map import newMap, member, del
derive gText TaskId, TaskListFilter
derive JSONEncode TaskId, TaskListFilter
derive gDefault TaskId, TaskListFilter
everyTick :: (*IWorld -> *(MaybeError TaskException (), *IWorld)) -> Task ()
everyTick f = Task eval
where
......@@ -36,45 +40,29 @@ 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 {InstanceFilter|defaultValue & includeSessions=True} filteredInstanceIndex) EmptyContext iworld of
(Ok (ReadingDone index), iworld) = checkAll (removeIfOutdated options) index iworld
removeOutdatedSessions = everyTick \iworld=:{IWorld|options} ->
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
(Error e,iworld) = (Error e,iworld)
removeIfOutdated options ((TaskId instanceNo _),_,_,_) iworld=:{options={appVersion},clock=tNow}
# (remove,iworld) = case read (sdsFocus instanceNo taskInstanceIO) EmptyContext iworld of
//If there is I/O information, we check that age first
(Ok (ReadingDone (Just (client,tInstance))),iworld) //No IO for too long, clean up
= (Ok ((tNow - tInstance) > options.EngineOptions.sessionTime),iworld)
//If there is no I/O information, get meta-data and check builtId and creation date
(Ok (ReadingDone Nothing),iworld)
= case read (sdsFocus instanceNo taskInstanceConstants) EmptyContext iworld of
(Ok (ReadingDone {InstanceConstants|build,issuedAt=tInstance}),iworld)
| build <> appVersion = (Ok True,iworld)
| (tNow - tInstance) > options.EngineOptions.sessionTime = (Ok True,iworld)
= (Ok False,iworld)
(Error e,iworld)
= (Error e,iworld)
(Error e,iworld)
= (Error e,iworld)
= case remove of
(Ok True)
removeIfOutdated options {TaskMeta|taskId=TaskId instanceNo _,connectedTo,lastIO,build,createdAt} iworld=:{options={appVersion},clock=tNow}
| if (lastIO =:(Just _))
(tNow - fromJust lastIO > options.EngineOptions.sessionTime)
((build <> appVersion) || ((tNow - createdAt) > options.EngineOptions.sessionTime))
# (e,iworld) = deleteTaskInstance instanceNo iworld
| e=:(Error _) = (e,iworld)
# (e,iworld) = write Nothing (sdsFocus instanceNo taskInstanceIO) EmptyContext iworld
| e=:(Error _) = (liftError e,iworld)
# (e,iworld) = modify (\output -> del instanceNo output) taskOutput EmptyContext iworld
| e=:(Error _) = (liftError e,iworld)
= (Ok (),iworld)
(Ok False)
= (Ok (), iworld)
(Error e)
= (Error e,iworld)
= (Ok (),iworld)
| otherwise
= (Ok (), iworld)
//When the event queue is empty, write deferred SDS's
flushWritesWhenIdle:: Task ()
......@@ -86,8 +74,8 @@ flushWritesWhenIdle = everyTick \iworld->case read taskEvents EmptyContext iworl
//When we don't run the built-in HTTP server we don't want to loop forever so we stop the loop
//once all non-system tasks are stable
stopOnStable :: Task ()
stopOnStable = everyTick \iworld->case read (sdsFocus {InstanceFilter|defaultValue & includeProgress=True, includeStartup=True, includeAttributes=True} filteredInstanceIndex) EmptyContext iworld of
(Ok (ReadingDone index), iworld)
stopOnStable = everyTick \iworld->case read (sdsFocus selection taskListMetaData) EmptyContext iworld of
(Ok (ReadingDone (_,index)), iworld)
# iworld = if (isNothing iworld.shutdown && all isStable (filter (not o isSystem) index))
{IWorld | iworld & shutdown=Just 0}
iworld
......@@ -96,11 +84,11 @@ stopOnStable = everyTick \iworld->case read (sdsFocus {InstanceFilter|defaultVal
= (Error (exception "Unexpeced SDS state"),iworld)
(Error e, iworld) = (Error e, iworld)
where
isStable (_, _, Nothing, _) = False
isStable (_, _, Just {InstanceProgress|value}, attributes) = value =: Stable
selection = (TaskId 0 0, TaskId 0 0,{TaskListFilter|fullTaskListFilter & includeProgress=True}
,{ExtendedTaskListFilter|fullExtendedTaskListFilter & includeStartup=True, includeSessions=False, includeDetached=False})
isSystem (_, _, Just {InstanceProgress|value}, attributes) = member "system" (maybe newMap mergeTaskAttributes attributes)
isSystem _ = False
isStable {TaskMeta|status} = fromRight False status
isSystem {TaskMeta|taskAttributes} = member "system" taskAttributes
printStdErr :: v !*IWorld -> *IWorld | gText{|*|} v
printStdErr v iw=:{world}
......
......@@ -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(..) , :: TIType(..), :: TaskChange(..)
from iTasks.Internal.TaskState import :: TaskMeta(..) , :: InstanceType(..), :: TaskChange(..)
import iTasks.Internal.TaskEval
from iTasks.SDS.Combinators.Common import toDynamic
......
......@@ -57,10 +57,5 @@ processEvents :: !Int *IWorld -> *(!MaybeError TaskException (), !*IWorld)
*/
evalTaskInstance :: !InstanceNo !Event !*IWorld -> (!MaybeErrorString (TaskValue DeferredJSON),!*IWorld)
//Update the I/O information for task instances
updateInstanceLastIO :: ![InstanceNo] !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
updateInstanceConnect :: !String ![InstanceNo] !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
updateInstanceDisconnect :: ![InstanceNo] !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
//Shares providing access to the evaluation information (constants from an evaluation point of view)
currentInstanceShare :: SDSSource () InstanceNo ()
This diff is collapsed.
......@@ -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, :: InstanceConstants
from iTasks.WF.Definition import :: InstanceNo, :: InstanceKey
from Data.GenEq import generic gEq
from Data.Error import :: MaybeError
from Data.Map import :: Map
......
......@@ -23,6 +23,7 @@ import iTasks.SDS.Definition
import iTasks.WF.Definition
import iTasks.WF.Derives
derive gDefault TaskId, TaskListFilter
//Helper type that holds the mainloop instances during a select call
//in these mainloop instances the unique listeners and read channels
//have been temporarily removed.
......@@ -54,9 +55,9 @@ where
queueAll :: !*IWorld -> *IWorld
queueAll iworld
# (mbIndex,iworld) = read (sdsFocus defaultValue filteredInstanceIndex) EmptyContext iworld
# (mbIndex,iworld) = read (sdsFocus defaultValue taskListMetaData) EmptyContext iworld //FIXME? Is the default filter what we want here?
= case mbIndex of
Ok (ReadingDone index) = foldl (\w (TaskId instanceNo _,_,_,_) -> queueEvent instanceNo ResetEvent w) iworld index
Ok (ReadingDone (_,index)) = foldl (\w {TaskMeta|taskId=(TaskId instanceNo _)}-> queueEvent instanceNo ResetEvent w) iworld index
_ = iworld
connectAll :: ![(Int,ConnectionTask)] !*World -> *(![*IOTaskInstance],!*World)
......
This diff is collapsed.
This diff is collapsed.
......@@ -15,6 +15,8 @@ import iTasks.Engine
import iTasks.Internal.Task, iTasks.Internal.TaskState, iTasks.Internal.TaskEval, iTasks.Internal.TaskIO
import iTasks.UI.Definition, iTasks.Internal.Util, iTasks.Internal.HtmlUtil, iTasks.Internal.IWorld
import iTasks.SDS.Combinators.Common
import iTasks.WF.Derives
import Crypto.Hash.SHA1, Text.Encodings.Base64, Text.Encodings.MIME
import Text.HTML
......@@ -432,15 +434,22 @@ where
(Just x,q) = [x:toList q]
verifyInstances :: [(InstanceNo,String)] *IWorld -> (![(InstanceNo,String)],![InstanceNo],![InstanceNo],!*IWorld)
verifyInstances instances iworld = foldl verify ([],[],[],iworld) instances
verifyInstances instances iworld
# tfilter = {TaskListFilter|fullTaskListFilter & onlyTaskId = Just [TaskId no 0 \\ (no,_) <- instances]}
# focus = (TaskId 0 0, TaskId 0 0,tfilter,fullExtendedTaskListFilter)
= case 'SDS'.read (sdsFocus focus taskListMetaData) 'SDS'.EmptyContext iworld of
(Ok (ReadingDone (_,metas)), iworld)
# metas = 'DM'.fromList [(no,m) \\ m=:{TaskMeta|taskId=TaskId no _} <- metas]
# (active,removed,revoked) = foldr (verify metas) ([],[],[]) instances
= (active,removed,revoked,iworld)
(_,iworld) = ([],map fst instances,[],iworld)
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)
= if (viewportKey == key)
([(instanceNo,viewportKey):active],removed,revoked,iworld)
(active,removed,[instanceNo:revoked],iworld)
(_,iworld) = (active,[instanceNo:removed],revoked,iworld)
verify metas (instanceNo,viewportKey) (active,removed,revoked) = case 'DM'.get instanceNo metas of