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
hostTaskPoolServer :: Task ()
hostTaskPoolServer
= getDomain
>>- \domain -> enterInformation "Task pool port" []
>>- \domain -> (Hint "Task pool port" @>> enterInformation [])
>>= \port -> (instanceServer port domain) -|| (instanceFilter (const True) domain)
connectToTaskPoolServer :: Task ()
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))
intermediateTaskPoolServer :: Task ()
intermediateTaskPoolServer
= enterInformation "Enter YOUR subdomain" []
>>= \subdomain -> enterInformation "Enter a port for YOUR task pool server" []
>>= \serverPort -> enterInformation "Connect to (master) task pool" []
= Hint "Enter YOUR subdomain" @>> enterInformation []
>>= \subdomain -> Hint "Enter a port for YOUR task pool server" @>> enterInformation []
>>= \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
askQuestion :: Task String
askQuestion
= get currentDomain
>>- \domain -> usersOf domain
>>- \users -> enterChoice "Select a user" [] users
>>= \user -> enterInformation "Question" []
>>- \users -> Hint "Select a user" @>> enterChoice [] users
>>= \user -> Hint "Question" @>> enterInformation []
>>= \question -> user @. domain @: (answer question)
>>- \answer -> viewInformation "Anser" [] answer
>>- \answer -> Hint "Anser" @>> viewInformation [] answer
where
answer :: String -> Task String
answer question
= enterInformation question []
= Hint question @>> enterInformation []
>>= return
:: TestRecord = {number :: Int, numbers :: [Int], text :: String, texts :: [String]}
......@@ -77,13 +77,13 @@ sharedExample :: Task TestRecord
sharedExample
= enterDomain
>>= \domain -> usersOf domain
>>= enterChoice "Task for:" []
>>= \users -> Hint "Task for:" @>> enterChoice [] users
>>= \user -> ((user @. domain) @: updateMyShared)
||- viewSharedInformation "myShare" [] myShared
||- (Hint "myShare" @>> viewSharedInformation [] myShared)
updateMyShared :: Task TestRecord
updateMyShared
= enterInformation "New value for shared" []
= Hint "New value for shared" @>> enterInformation []
>>= \val -> set val myShared
:: ServerRole = DomainServer Domain
......@@ -110,7 +110,7 @@ startMode executable
>>| installWorkflows (myTasks True)
>>| loginAndManageWork "Service engineer application" Nothing Nothing 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 "Server") (always (server))
]
......@@ -132,7 +132,7 @@ where
loginRemote :: ![Workflow] -> Task ()
loginRemote workflows
= forever (
enterInformation "Enter your credentials and login" []
Hint "Enter your credentials and login" @>> enterInformation []
>>* [OnAction (Action "Login") (hasValue (browseAuthenticated workflows))
]
)
......@@ -141,7 +141,7 @@ where
= remoteAuthenticateUser username password
>>= \mbUser -> case mbUser of
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 = doTasks [ publish "/" (\_-> startMode (IF_WINDOWS "examples.exe" "examples"))] world
......@@ -10,9 +10,10 @@ from iTasks.Internal.Generic.Visualization import :: TextFormat(..)
from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode
from Data.Maybe import :: Maybe
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.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
import StdString
......@@ -28,5 +29,5 @@ device = sharedStore "deviceFeaturs" {DeviceFeatures| camera = False }
manageDeviceFeaturs :: Task DeviceFeatures
manageDeviceFeaturs
= get device
>>- \info -> updateInformation "Manage device features" [] info
>>- \info -> Hint "Manage device features" @>> updateInformation [] info
>>= \info -> set info device
......@@ -203,4 +203,4 @@ currentDomain = toReadOnly (mapRead (\domain -> Domain domain) authServerInfoSha
enterDomain :: Task Domain
enterDomain
= 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
from iTasks.Internal.Generic.Visualization import :: TextFormat(..)
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
import iTasks
viewSharedInformation :: String [ViewOption r] !(sds () r w) -> Task r | iTask r & iTask w & RWShared sds
viewSharedInformation title options share
viewSharedInformation :: [ViewOption r] !(sds () r w) -> Task r | iTask r & iTask w & RWShared sds
viewSharedInformation options share
= watch share
>>* [OnValue (hasValue return)]
>>- \v -> loop v title options share
>>- \v -> loop v options share
where
loop :: r String [ViewOption r] (sds () r w) -> Task r | iTask r & iTask w & RWShared sds
loop v title options share
= (viewInformation title options v)
loop :: r [ViewOption r] (sds () r w) -> Task r | iTask r & iTask w & RWShared sds
loop v options share
= (viewInformation options v)
||- (watch share >>* [OnValue (ifValue ((=!=) v) return)])
>>- \v -> loop v title options share
>>- \v -> loop v options share
......@@ -28,11 +28,11 @@ where
(@:) worker task
= 'C'.get currentUser -&&- 'C'.get currentDateTime
>>- \(me,now) -> assign (workerAttributes worker
[ ("title", toTitle worker)
, ("createdBy", toString (toUserConstraint me))
, ("createdAt", toString now)
, ("priority", toString 5)
, ("createdFor", toString (toUserConstraint worker))
[ ("title", toJSON (toTitle worker))
, ("createdBy", toJSON (toUserConstraint me))
, ("createdAt", toJSON now)
, ("priority", toJSON 5)
, ("createdFor", toJSON (toUserConstraint worker))
]) task
instance @: Domain (Task a) | iTask a
......@@ -40,10 +40,10 @@ where
(@:) domain task
= 'C'.get currentUser -&&- 'C'.get currentDateTime
>>- \(me,now) -> remoteAssignTask (fromList
[ ("title", "None")
, ("createdBy", toString (toUserConstraint me))
, ("createdAt", toString now)
, ("priority", toString 5)
[ ("title", toJSON "None")
, ("createdBy", toJSON (toUserConstraint me))
, ("createdAt", toJSON now)
, ("priority", toJSON 5)
]) task domain
instance @: DomainUser (Task a) | iTask a
......@@ -51,11 +51,11 @@ where
(@:) (DomainUser worker domain) task
= 'C'.get currentUser -&&- 'C'.get currentDateTime
>>- \(me,now) -> remoteAssignTask (fromList
[ ("title", toTitle worker)
, ("createdBy", toString (toUserConstraint me))
, ("createdAt", toString now)
, ("priority", toString 5)
, ("createdFor", toString (toUserConstraint worker))
[ ("title", toJSON (toTitle worker))
, ("createdBy", toJSON (toUserConstraint me))
, ("createdAt", toJSON now)
, ("priority", toJSON 5)
, ("createdFor", toJSON (toUserConstraint worker))
]) task domain
instance @: Requires (Task a) | iTask a
......@@ -64,11 +64,11 @@ where
= 'C'.get currentUser -&&- 'C'.get currentDateTime
>>- \(me,now) -> 'C'.get currentDomain
>>- \domain -> remoteAssignTask (fromList
[ ("title", "None")
, ("createdBy", toString (toUserConstraint me))
, ("createdAt", toString now)
, ("priority", toString 5)
, ("requires", requires)
[ ("title", toJSON "None")
, ("createdBy", toJSON (toUserConstraint me))
, ("createdAt", toJSON now)
, ("priority", toJSON 5)
, ("requires", toJSON requires)
]) task domain
......
......@@ -53,7 +53,7 @@ where
eval value_share event evalOpts tree=:(TCInit taskId ts) iworld
# (val,iworld) = readRegister taskId value_share iworld
= 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)
rep ResetEvent = ReplaceUI (ui UIEmpty)
......
......@@ -34,7 +34,9 @@ where
waitForDateTime` :: !DateTime -> Task 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)
, OnAction (Action "Reconnect") (always (return datetime))
]
......@@ -20,6 +20,8 @@ import qualified iTasks.Extensions.User as U
from iTasks.WF.Combinators.Common import -&&-, >>-
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.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.WF.Tasks.Core import accWorld
import iTasks.Internal.Distributed.Symbols
......@@ -31,7 +33,7 @@ from iTasks.Engine import doTasksWithOptions, doTasks, :: StartableTask, onReque
from Internet.HTTP import :: HTTPRequest(..), :: HTTPUpload, :: HTTPProtocol, :: HTTPMethod
import iTasks.WF.Combinators.Common
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.Admin.UserAdmin import manageUsers
from iTasks.SDS.Sources.System import currentTime
......@@ -49,8 +51,6 @@ from Internet.HTTP import :: HTTPResponse{..}, :: HTTPMethod(..)
from Text.URI import :: URI{..}, parseURI
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.Picture.JPEG import :: JPEGPicture(..)
from iTasks.Extensions.Device.Camera import takePicture
......
......@@ -14,7 +14,7 @@ from iTasks.UI.Editor.Modifiers import comapEditorValue, instance tune UIAttribu
from iTasks.UI.Editor.Controls import htmlView
from iTasks.UI.Definition import :: UIAttributes
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 JSONEncode JPEGPicture
......
......@@ -475,7 +475,7 @@ where
, onDisconnect = onDisconnect
, onDestroy = \s->(Ok s, [])
} @! 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 helloMessage connId host store
......@@ -525,13 +525,13 @@ where
handleRequest :: [String] {#Symbol} -> Task (Maybe Int, [String])
handleRequest ["instance", "notify", instanceno, attributes] symbols
# attributes = deserializeFromBase64 attributes symbols
= getTaskIdByAttribute "distributedInstanceId" instanceno
= getTaskIdByAttribute "distributedInstanceId" (JSONString instanceno)
>>= \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 (Nothing, [])
handleRequest ["instance", "destory", instanceno] _
= getTaskIdByAttribute "distributedInstanceId" instanceno
= getTaskIdByAttribute "distributedInstanceId" (JSONString instanceno)
>>- \id -> if (isNothing id)
(return ())
(removeTask (TaskId (fromJust id) 0) topLevelTasks @! ())
......@@ -602,7 +602,7 @@ sendRequestToInstanceServer :: Int String -> Task ()
sendRequestToInstanceServer clientId request
= 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
where
attrb = mapRead find (sdsFocus (key,value) taskInstancesByAttribute)
......@@ -612,7 +612,7 @@ where
_ = Nothing
hasValue key value attributes
= maybe False ((==) value) ('DM'.get key attributes)
= maybe False ((===) value) ('DM'.get key attributes)
// ---- Wrapper task
......@@ -624,18 +624,18 @@ wrapperTask instanceno clientId
where
loadTask :: InstanceNo Bool (Shared sds String) -> Task String | RWShared sds
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)
>>| sendRequestToInstanceServer clientId ("instance " +++ (if force "get-force " "get ") +++ (toString instanceno))
>>| (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 data = set data shared @! ()
assinged :: InstanceNo (Shared sds String) -> Task String | RWShared sds
assinged instanceno shared
= viewInformation "Task is assigned to another node" []
assigned :: InstanceNo (Shared sds String) -> Task String | RWShared sds
assigned instanceno shared
= 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."
>>* [OnAction (Action "Take over") (always (return ()))]
>>| set "" shared
......@@ -645,7 +645,6 @@ where
valueChange instanceno value
= sendRequestToInstanceServer clientId ("value " +++ (toString instanceno) +++ " none " +++ serializeToBase64 (Remote_TaskValue value))
:: WrapperTaskHandelers :== Map Int String
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