Commit 173a9ccf authored by Bas Lijnse's avatar Bas Lijnse

Adapted more modules to changes in interaction task api

parent e72c0164
Pipeline #26152 failed with stage
in 2 minutes and 5 seconds
...@@ -38,33 +38,33 @@ derive class iTask ConnectToTaskPool ...@@ -38,33 +38,33 @@ derive class iTask ConnectToTaskPool
hostTaskPoolServer :: Task () hostTaskPoolServer :: Task ()
hostTaskPoolServer hostTaskPoolServer
= getDomain = getDomain
>>- \domain -> enterInformation "Task pool port" [] >>- \domain -> (Hint "Task pool port" @>> enterInformation [])
>>= \port -> (instanceServer port domain) -|| (instanceFilter (const True) domain) >>= \port -> (instanceServer port domain) -|| (instanceFilter (const True) domain)
connectToTaskPoolServer :: Task () connectToTaskPoolServer :: Task ()
connectToTaskPoolServer connectToTaskPoolServer
= enterInformation "Connect to task pool" [] = Hint "Connect to task pool" @>> enterInformation []
>>= \{ConnectToTaskPool|domain=(Domain host),port} -> (instanceClient host port (Domain host)) -|| (instanceFilter (const True) (Domain host)) >>= \{ConnectToTaskPool|domain=(Domain host),port} -> (instanceClient host port (Domain host)) -|| (instanceFilter (const True) (Domain host))
intermediateTaskPoolServer :: Task () intermediateTaskPoolServer :: Task ()
intermediateTaskPoolServer intermediateTaskPoolServer
= enterInformation "Enter YOUR subdomain" [] = Hint "Enter YOUR subdomain" @>> enterInformation []
>>= \subdomain -> enterInformation "Enter a port for YOUR task pool server" [] >>= \subdomain -> Hint "Enter a port for YOUR task pool server" @>> enterInformation []
>>= \serverPort -> enterInformation "Connect to (master) task pool" [] >>= \serverPort -> Hint "Connect to (master) task pool" @>> enterInformation []
>>= \{ConnectToTaskPool|domain=(Domain host),port} -> ((instanceClient host port (Domain host)) -|| (instanceClameFilter (const True) (Domain host))) -|| instanceServer serverPort subdomain >>= \{ConnectToTaskPool|domain=(Domain host),port} -> ((instanceClient host port (Domain host)) -|| (instanceClameFilter (const True) (Domain host))) -|| instanceServer serverPort subdomain
askQuestion :: Task String askQuestion :: Task String
askQuestion askQuestion
= get currentDomain = get currentDomain
>>- \domain -> usersOf domain >>- \domain -> usersOf domain
>>- \users -> enterChoice "Select a user" [] users >>- \users -> Hint "Select a user" @>> enterChoice [] users
>>= \user -> enterInformation "Question" [] >>= \user -> Hint "Question" @>> enterInformation []
>>= \question -> user @. domain @: (answer question) >>= \question -> user @. domain @: (answer question)
>>- \answer -> viewInformation "Anser" [] answer >>- \answer -> Hint "Anser" @>> viewInformation [] answer
where where
answer :: String -> Task String answer :: String -> Task String
answer question answer question
= enterInformation question [] = Hint question @>> enterInformation []
>>= return >>= return
:: TestRecord = {number :: Int, numbers :: [Int], text :: String, texts :: [String]} :: TestRecord = {number :: Int, numbers :: [Int], text :: String, texts :: [String]}
...@@ -77,13 +77,13 @@ sharedExample :: Task TestRecord ...@@ -77,13 +77,13 @@ sharedExample :: Task TestRecord
sharedExample sharedExample
= enterDomain = enterDomain
>>= \domain -> usersOf domain >>= \domain -> usersOf domain
>>= enterChoice "Task for:" [] >>= \users -> Hint "Task for:" @>> enterChoice [] users
>>= \user -> ((user @. domain) @: updateMyShared) >>= \user -> ((user @. domain) @: updateMyShared)
||- viewSharedInformation "myShare" [] myShared ||- (Hint "myShare" @>> viewSharedInformation [] myShared)
updateMyShared :: Task TestRecord updateMyShared :: Task TestRecord
updateMyShared updateMyShared
= enterInformation "New value for shared" [] = Hint "New value for shared" @>> enterInformation []
>>= \val -> set val myShared >>= \val -> set val myShared
:: ServerRole = DomainServer Domain :: ServerRole = DomainServer Domain
...@@ -110,7 +110,7 @@ startMode executable ...@@ -110,7 +110,7 @@ startMode executable
>>| installWorkflows (myTasks True) >>| installWorkflows (myTasks True)
>>| loginAndManageWork "Service engineer application" Nothing Nothing False >>| loginAndManageWork "Service engineer application" Nothing Nothing False
Server domain -> startAuthEngine domain >>| loginRemote (myTasks False) Server domain -> startAuthEngine domain >>| loginRemote (myTasks False)
_ -> viewInformation "Welcome" [] "Chose what this iTasks instance is." _ -> Title "Welcome" @>> viewInformation [] "Choose what this iTasks instance is."
>>* [ OnAction (Action "Domain server") (always (domainServer)) >>* [ OnAction (Action "Domain server") (always (domainServer))
, OnAction (Action "Server") (always (server)) , OnAction (Action "Server") (always (server))
] ]
...@@ -132,7 +132,7 @@ where ...@@ -132,7 +132,7 @@ where
loginRemote :: ![Workflow] -> Task () loginRemote :: ![Workflow] -> Task ()
loginRemote workflows loginRemote workflows
= forever ( = forever (
enterInformation "Enter your credentials and login" [] Hint "Enter your credentials and login" @>> enterInformation []
>>* [OnAction (Action "Login") (hasValue (browseAuthenticated workflows)) >>* [OnAction (Action "Login") (hasValue (browseAuthenticated workflows))
] ]
) )
...@@ -141,7 +141,7 @@ where ...@@ -141,7 +141,7 @@ where
= remoteAuthenticateUser username password = remoteAuthenticateUser username password
>>= \mbUser -> case mbUser of >>= \mbUser -> case mbUser of
Just user = workAs user (manageWorkOfCurrentUser Nothing) Just user = workAs user (manageWorkOfCurrentUser Nothing)
Nothing = viewInformation (Title "Login failed") [] "Your username or password is incorrect" >>| return () Nothing = Title "Login failed" @>> viewInformation [] "Your username or password is incorrect" >>| return ()
Start :: *World -> *World Start :: *World -> *World
Start world = doTasks [ publish "/" (\_-> startMode (IF_WINDOWS "examples.exe" "examples"))] world Start world = doTasks [ publish "/" (\_-> startMode (IF_WINDOWS "examples.exe" "examples"))] world
...@@ -10,9 +10,10 @@ from iTasks.Internal.Generic.Visualization import :: TextFormat(..) ...@@ -10,9 +10,10 @@ from iTasks.Internal.Generic.Visualization import :: TextFormat(..)
from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode
from Data.Maybe import :: Maybe from Data.Maybe import :: Maybe
from iTasks.WF.Tasks.Interaction import :: UpdateOption, updateInformation from iTasks.WF.Tasks.Interaction import :: UpdateOption, updateInformation
from iTasks.UI.Prompt import class toPrompt, instance toPrompt String
from iTasks.WF.Combinators.Common import >>- from iTasks.WF.Combinators.Common import >>-
from iTasks.WF.Combinators.Overloaded import instance Functor Task, instance TMonad Task, class TMonad(..), class TApplicative, instance TApplicative Task from iTasks.WF.Combinators.Overloaded import instance Functor Task, instance TMonad Task, class TMonad(..), class TApplicative, instance TApplicative Task
from iTasks.UI.Definition import :: Hint(..)
from iTasks.UI.Tune import class tune(..), @>>, instance tune Hint Task
from Data.Functor import class Functor from Data.Functor import class Functor
import StdString import StdString
...@@ -28,5 +29,5 @@ device = sharedStore "deviceFeaturs" {DeviceFeatures| camera = False } ...@@ -28,5 +29,5 @@ device = sharedStore "deviceFeaturs" {DeviceFeatures| camera = False }
manageDeviceFeaturs :: Task DeviceFeatures manageDeviceFeaturs :: Task DeviceFeatures
manageDeviceFeaturs manageDeviceFeaturs
= get device = get device
>>- \info -> updateInformation "Manage device features" [] info >>- \info -> Hint "Manage device features" @>> updateInformation [] info
>>= \info -> set info device >>= \info -> set info device
...@@ -203,4 +203,4 @@ currentDomain = toReadOnly (mapRead (\domain -> Domain domain) authServerInfoSha ...@@ -203,4 +203,4 @@ currentDomain = toReadOnly (mapRead (\domain -> Domain domain) authServerInfoSha
enterDomain :: Task Domain enterDomain :: Task Domain
enterDomain enterDomain
= get authServerInfoShare = get authServerInfoShare
>>- \domain -> updateInformation "Enter domain" [] (Domain domain) >>- \domain -> Hint "Enter domain" @>> updateInformation [] (Domain domain)
...@@ -8,4 +8,4 @@ from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode ...@@ -8,4 +8,4 @@ from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode
from iTasks.Internal.Generic.Visualization import :: TextFormat(..) from iTasks.Internal.Generic.Visualization import :: TextFormat(..)
from iTasks.WF.Tasks.Interaction import :: ViewOption(..) from iTasks.WF.Tasks.Interaction import :: ViewOption(..)
viewSharedInformation :: String [ViewOption r] !(sds () r w) -> Task r | iTask r & iTask w & RWShared sds viewSharedInformation :: [ViewOption r] !(sds () r w) -> Task r | iTask r & iTask w & RWShared sds
...@@ -2,14 +2,14 @@ implementation module iTasks.Extensions.Distributed.InteractionTasks ...@@ -2,14 +2,14 @@ implementation module iTasks.Extensions.Distributed.InteractionTasks
import iTasks import iTasks
viewSharedInformation :: String [ViewOption r] !(sds () r w) -> Task r | iTask r & iTask w & RWShared sds viewSharedInformation :: [ViewOption r] !(sds () r w) -> Task r | iTask r & iTask w & RWShared sds
viewSharedInformation title options share viewSharedInformation options share
= watch share = watch share
>>* [OnValue (hasValue return)] >>* [OnValue (hasValue return)]
>>- \v -> loop v title options share >>- \v -> loop v options share
where where
loop :: r String [ViewOption r] (sds () r w) -> Task r | iTask r & iTask w & RWShared sds loop :: r [ViewOption r] (sds () r w) -> Task r | iTask r & iTask w & RWShared sds
loop v title options share loop v options share
= (viewInformation title options v) = (viewInformation options v)
||- (watch share >>* [OnValue (ifValue ((=!=) v) return)]) ||- (watch share >>* [OnValue (ifValue ((=!=) v) return)])
>>- \v -> loop v title options share >>- \v -> loop v options share
...@@ -28,11 +28,11 @@ where ...@@ -28,11 +28,11 @@ where
(@:) worker task (@:) worker task
= 'C'.get currentUser -&&- 'C'.get currentDateTime = 'C'.get currentUser -&&- 'C'.get currentDateTime
>>- \(me,now) -> assign (workerAttributes worker >>- \(me,now) -> assign (workerAttributes worker
[ ("title", toTitle worker) [ ("title", toJSON (toTitle worker))
, ("createdBy", toString (toUserConstraint me)) , ("createdBy", toJSON (toUserConstraint me))
, ("createdAt", toString now) , ("createdAt", toJSON now)
, ("priority", toString 5) , ("priority", toJSON 5)
, ("createdFor", toString (toUserConstraint worker)) , ("createdFor", toJSON (toUserConstraint worker))
]) task ]) task
instance @: Domain (Task a) | iTask a instance @: Domain (Task a) | iTask a
...@@ -40,10 +40,10 @@ where ...@@ -40,10 +40,10 @@ where
(@:) domain task (@:) domain task
= 'C'.get currentUser -&&- 'C'.get currentDateTime = 'C'.get currentUser -&&- 'C'.get currentDateTime
>>- \(me,now) -> remoteAssignTask (fromList >>- \(me,now) -> remoteAssignTask (fromList
[ ("title", "None") [ ("title", toJSON "None")
, ("createdBy", toString (toUserConstraint me)) , ("createdBy", toJSON (toUserConstraint me))
, ("createdAt", toString now) , ("createdAt", toJSON now)
, ("priority", toString 5) , ("priority", toJSON 5)
]) task domain ]) task domain
instance @: DomainUser (Task a) | iTask a instance @: DomainUser (Task a) | iTask a
...@@ -51,11 +51,11 @@ where ...@@ -51,11 +51,11 @@ where
(@:) (DomainUser worker domain) task (@:) (DomainUser worker domain) task
= 'C'.get currentUser -&&- 'C'.get currentDateTime = 'C'.get currentUser -&&- 'C'.get currentDateTime
>>- \(me,now) -> remoteAssignTask (fromList >>- \(me,now) -> remoteAssignTask (fromList
[ ("title", toTitle worker) [ ("title", toJSON (toTitle worker))
, ("createdBy", toString (toUserConstraint me)) , ("createdBy", toJSON (toUserConstraint me))
, ("createdAt", toString now) , ("createdAt", toJSON now)
, ("priority", toString 5) , ("priority", toJSON 5)
, ("createdFor", toString (toUserConstraint worker)) , ("createdFor", toJSON (toUserConstraint worker))
]) task domain ]) task domain
instance @: Requires (Task a) | iTask a instance @: Requires (Task a) | iTask a
...@@ -64,11 +64,11 @@ where ...@@ -64,11 +64,11 @@ where
= 'C'.get currentUser -&&- 'C'.get currentDateTime = 'C'.get currentUser -&&- 'C'.get currentDateTime
>>- \(me,now) -> 'C'.get currentDomain >>- \(me,now) -> 'C'.get currentDomain
>>- \domain -> remoteAssignTask (fromList >>- \domain -> remoteAssignTask (fromList
[ ("title", "None") [ ("title", toJSON "None")
, ("createdBy", toString (toUserConstraint me)) , ("createdBy", toJSON (toUserConstraint me))
, ("createdAt", toString now) , ("createdAt", toJSON now)
, ("priority", toString 5) , ("priority", toJSON 5)
, ("requires", requires) , ("requires", toJSON requires)
]) task domain ]) task domain
......
...@@ -53,7 +53,7 @@ where ...@@ -53,7 +53,7 @@ where
eval value_share event evalOpts tree=:(TCInit taskId ts) iworld eval value_share event evalOpts tree=:(TCInit taskId ts) iworld
# (val,iworld) = readRegister taskId value_share iworld # (val,iworld) = readRegister taskId value_share iworld
= case val of = case val of
Ok (ReadingDone val) = (ValueResult val {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes=newMap} (rep event) tree, iworld) Ok (ReadingDone val) = (ValueResult val {TaskEvalInfo|lastEvent=ts,removedTasks=[]} (rep event) tree, iworld)
Error e = (ExceptionResult e,iworld) Error e = (ExceptionResult e,iworld)
rep ResetEvent = ReplaceUI (ui UIEmpty) rep ResetEvent = ReplaceUI (ui UIEmpty)
......
...@@ -34,7 +34,9 @@ where ...@@ -34,7 +34,9 @@ where
waitForDateTime` :: !DateTime -> Task DateTime waitForDateTime` :: !DateTime -> Task DateTime
waitForDateTime` datetime waitForDateTime` datetime
= viewSharedInformation ("Connection interrupted", ("The connection with the other controller is interrupted, next attempt: " +++ toString datetime)) [] currentUTCDateTime >>* [OnValue (ifValue (\now -> datetime < now) return)] = Title "Connection interrupted" @>>
Hint ("The connection with the other controller is interrupted, next attempt: " +++ toString datetime) @>>
viewSharedInformation [] currentUTCDateTime >>* [OnValue (ifValue (\now -> datetime < now) return)]
>>* [ OnValue (ifValue (\now -> datetime < now) return) >>* [ OnValue (ifValue (\now -> datetime < now) return)
, OnAction (Action "Reconnect") (always (return datetime)) , OnAction (Action "Reconnect") (always (return datetime))
] ]
...@@ -20,6 +20,8 @@ import qualified iTasks.Extensions.User as U ...@@ -20,6 +20,8 @@ import qualified iTasks.Extensions.User as U
from iTasks.WF.Combinators.Common import -&&-, >>- from iTasks.WF.Combinators.Common import -&&-, >>-
from iTasks.SDS.Sources.System import currentDateTime from iTasks.SDS.Sources.System import currentDateTime
from iTasks.Extensions.User import currentUser, :: User(..), :: UserTitle, :: Role, :: UserId, assign, workerAttributes, :: Password, :: Username, workAs, :: Credentials{..}, users from iTasks.Extensions.User import currentUser, :: User(..), :: UserTitle, :: Role, :: UserId, assign, workerAttributes, :: Password, :: Username, workAs, :: Credentials{..}, users
from iTasks.UI.Definition import :: Title(..), :: Hint(..)
from iTasks.UI.Tune import @>>, <<@, class tune, instance tune Hint Task, instance tune Title Task
from iTasks.SDS.Definition import class RWShared(..) from iTasks.SDS.Definition import class RWShared(..)
from iTasks.WF.Tasks.Core import accWorld from iTasks.WF.Tasks.Core import accWorld
import iTasks.Internal.Distributed.Symbols import iTasks.Internal.Distributed.Symbols
...@@ -31,7 +33,7 @@ from iTasks.Engine import doTasksWithOptions, doTasks, :: StartableTask, onReque ...@@ -31,7 +33,7 @@ from iTasks.Engine import doTasksWithOptions, doTasks, :: StartableTask, onReque
from Internet.HTTP import :: HTTPRequest(..), :: HTTPUpload, :: HTTPProtocol, :: HTTPMethod from Internet.HTTP import :: HTTPRequest(..), :: HTTPUpload, :: HTTPProtocol, :: HTTPMethod
import iTasks.WF.Combinators.Common import iTasks.WF.Combinators.Common
from iTasks.WF.Combinators.Common import :: TaskCont from iTasks.WF.Combinators.Common import :: TaskCont
from iTasks.WF.Tasks.Interaction import enterInformation, :: EnterOption, :: ViewOption, enterChoice, :: ChoiceOption, viewInformation, enterChoiceWithShared, updateInformationWithShared, updateSharedInformation, :: UpdateOption from iTasks.WF.Tasks.Interaction import enterInformation, :: EnterOption, :: ViewOption, enterChoice, :: ChoiceOption, viewInformation, enterChoiceWithShared, updateInformationWithShared, updateSharedInformation, :: UpdateOption, :: UpdateSharedOption
from iTasks.Extensions.DateTime import :: DateTime, :: Time, waitForTimer from iTasks.Extensions.DateTime import :: DateTime, :: Time, waitForTimer
from iTasks.Extensions.Admin.UserAdmin import manageUsers from iTasks.Extensions.Admin.UserAdmin import manageUsers
from iTasks.SDS.Sources.System import currentTime from iTasks.SDS.Sources.System import currentTime
...@@ -49,8 +51,6 @@ from Internet.HTTP import :: HTTPResponse{..}, :: HTTPMethod(..) ...@@ -49,8 +51,6 @@ from Internet.HTTP import :: HTTPResponse{..}, :: HTTPMethod(..)
from Text.URI import :: URI{..}, parseURI from Text.URI import :: URI{..}, parseURI
from iTasks.Extensions.Web import callHTTP from iTasks.Extensions.Web import callHTTP
from iTasks.UI.Prompt import :: Title(..), instance toPrompt Title, class toPrompt, instance toPrompt String, instance toPrompt ()
from iTasks.Extensions.Device.Features import hasCamera, device, :: DeviceFeatures, manageDeviceFeaturs from iTasks.Extensions.Device.Features import hasCamera, device, :: DeviceFeatures, manageDeviceFeaturs
from iTasks.Extensions.Picture.JPEG import :: JPEGPicture(..) from iTasks.Extensions.Picture.JPEG import :: JPEGPicture(..)
from iTasks.Extensions.Device.Camera import takePicture from iTasks.Extensions.Device.Camera import takePicture
......
...@@ -14,7 +14,7 @@ from iTasks.UI.Editor.Modifiers import comapEditorValue, instance tune UIAttribu ...@@ -14,7 +14,7 @@ from iTasks.UI.Editor.Modifiers import comapEditorValue, instance tune UIAttribu
from iTasks.UI.Editor.Controls import htmlView from iTasks.UI.Editor.Controls import htmlView
from iTasks.UI.Definition import :: UIAttributes from iTasks.UI.Definition import :: UIAttributes
from Text.HTML import :: HtmlTag(ImgTag), :: HtmlAttr(SrcAttr,StyleAttr,AltAttr) from Text.HTML import :: HtmlTag(ImgTag), :: HtmlAttr(SrcAttr,StyleAttr,AltAttr)
from iTasks.WF.Combinators.Tune import <<@, class tune from iTasks.UI.Tune import <<@, class tune
derive gText JPEGPicture derive gText JPEGPicture
derive JSONEncode JPEGPicture derive JSONEncode JPEGPicture
......
...@@ -475,7 +475,7 @@ where ...@@ -475,7 +475,7 @@ where
, onDisconnect = onDisconnect , onDisconnect = onDisconnect
, onDestroy = \s->(Ok s, []) , onDestroy = \s->(Ok s, [])
} @! Nothing) } @! Nothing)
-||- (viewInformation () [] () >>* [OnAction (Action "reset") (always (return Nothing))]) -||- (viewInformation [] () >>* [OnAction (Action "reset") (always (return Nothing))])
onConnect :: String ConnectionId String ClientShare -> (MaybeErrorString ClientState, Maybe ClientShare, [String], Bool) onConnect :: String ConnectionId String ClientShare -> (MaybeErrorString ClientState, Maybe ClientShare, [String], Bool)
onConnect helloMessage connId host store onConnect helloMessage connId host store
...@@ -525,13 +525,13 @@ where ...@@ -525,13 +525,13 @@ where
handleRequest :: [String] {#Symbol} -> Task (Maybe Int, [String]) handleRequest :: [String] {#Symbol} -> Task (Maybe Int, [String])
handleRequest ["instance", "notify", instanceno, attributes] symbols handleRequest ["instance", "notify", instanceno, attributes] symbols
# attributes = deserializeFromBase64 attributes symbols # attributes = deserializeFromBase64 attributes symbols
= getTaskIdByAttribute "distributedInstanceId" instanceno = getTaskIdByAttribute "distributedInstanceId" (JSONString instanceno)
>>= \id -> if (isNothing id) >>= \id -> if (isNothing id)
(appendTopLevelTask ('DM'.put "distributedInstanceServerId" (toString clientId) ('DM'.put "distributedInstanceId" instanceno attributes)) False (wrapperTask (toInt instanceno) clientId) @! ()) (appendTopLevelTask ('DM'.put "distributedInstanceServerId" (JSONString (toString clientId)) ('DM'.put "distributedInstanceId" (JSONString instanceno) attributes)) False (wrapperTask (toInt instanceno) clientId) @! ())
(return ()) (return ())
>>| return (Nothing, []) >>| return (Nothing, [])
handleRequest ["instance", "destory", instanceno] _ handleRequest ["instance", "destory", instanceno] _
= getTaskIdByAttribute "distributedInstanceId" instanceno = getTaskIdByAttribute "distributedInstanceId" (JSONString instanceno)
>>- \id -> if (isNothing id) >>- \id -> if (isNothing id)
(return ()) (return ())
(removeTask (TaskId (fromJust id) 0) topLevelTasks @! ()) (removeTask (TaskId (fromJust id) 0) topLevelTasks @! ())
...@@ -602,7 +602,7 @@ sendRequestToInstanceServer :: Int String -> Task () ...@@ -602,7 +602,7 @@ sendRequestToInstanceServer :: Int String -> Task ()
sendRequestToInstanceServer clientId request sendRequestToInstanceServer clientId request
= upd (\s=:{ClientShare|responses=or} -> {ClientShare| s & responses = or ++ [request]}) (instanceClientShare clientId) @! () = upd (\s=:{ClientShare|responses=or} -> {ClientShare| s & responses = or ++ [request]}) (instanceClientShare clientId) @! ()
getTaskIdByAttribute :: String String -> Task (Maybe InstanceNo) getTaskIdByAttribute :: String JSONNode -> Task (Maybe InstanceNo)
getTaskIdByAttribute key value = get attrb getTaskIdByAttribute key value = get attrb
where where
attrb = mapRead find (sdsFocus (key,value) taskInstancesByAttribute) attrb = mapRead find (sdsFocus (key,value) taskInstancesByAttribute)
...@@ -612,7 +612,7 @@ where ...@@ -612,7 +612,7 @@ where
_ = Nothing _ = Nothing
hasValue key value attributes hasValue key value attributes
= maybe False ((==) value) ('DM'.get key attributes) = maybe False ((===) value) ('DM'.get key attributes)
// ---- Wrapper task // ---- Wrapper task
...@@ -624,18 +624,18 @@ wrapperTask instanceno clientId ...@@ -624,18 +624,18 @@ wrapperTask instanceno clientId
where where
loadTask :: InstanceNo Bool (Shared sds String) -> Task String | RWShared sds loadTask :: InstanceNo Bool (Shared sds String) -> Task String | RWShared sds
loadTask instanceno force shared loadTask instanceno force shared
= viewInformation "Loading task" [] "Please wait, the task is loaded ..." = Title "Loading task" @>> viewInformation [] "Please wait, the task is loaded ..."
||- (addWrapperTaskHandler instanceno (handlerTask shared) ||- (addWrapperTaskHandler instanceno (handlerTask shared)
>>| sendRequestToInstanceServer clientId ("instance " +++ (if force "get-force " "get ") +++ (toString instanceno)) >>| sendRequestToInstanceServer clientId ("instance " +++ (if force "get-force " "get ") +++ (toString instanceno))
>>| (watch shared >>* [OnValue (ifValue (\v -> not (v == "")) return)]) >>| (watch shared >>* [OnValue (ifValue (\v -> not (v == "")) return)])
) >>- \result -> if (result=="ASSIGNED") (assinged instanceno shared) (return result) ) >>- \result -> if (result=="ASSIGNED") (assigned instanceno shared) (return result)
handlerTask :: (Shared sds String) String -> Task () | RWShared sds handlerTask :: (Shared sds String) String -> Task () | RWShared sds
handlerTask shared data = set data shared @! () handlerTask shared data = set data shared @! ()
assinged :: InstanceNo (Shared sds String) -> Task String | RWShared sds assigned :: InstanceNo (Shared sds String) -> Task String | RWShared sds
assinged instanceno shared assigned instanceno shared
= viewInformation "Task is assigned to another node" [] = Hint "Task is assigned to another node" @>> viewInformation []
"You can takeover the task. Please take in mind that the progress at the other device maybe lost." "You can takeover the task. Please take in mind that the progress at the other device maybe lost."
>>* [OnAction (Action "Take over") (always (return ()))] >>* [OnAction (Action "Take over") (always (return ()))]
>>| set "" shared >>| set "" shared
...@@ -645,7 +645,6 @@ where ...@@ -645,7 +645,6 @@ where
valueChange instanceno value valueChange instanceno value
= sendRequestToInstanceServer clientId ("value " +++ (toString instanceno) +++ " none " +++ serializeToBase64 (Remote_TaskValue value)) = sendRequestToInstanceServer clientId ("value " +++ (toString instanceno) +++ " none " +++ serializeToBase64 (Remote_TaskValue value))
:: WrapperTaskHandelers :== Map Int String :: WrapperTaskHandelers :== Map Int String
wrapperTaskHandelersShare :: SimpleSDSLens WrapperTaskHandelers wrapperTaskHandelersShare :: SimpleSDSLens WrapperTaskHandelers
......
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