implementation module TaskService import Http, TSt import HtmlUtil, Text import JSON import StdList import ProcessDB import TaskPanel from InteractionTasks import :: MenuItem derive bimap (,), Maybe //Additional derives for debugging derive JSONEncode TaskInfo, Hotkey, Key derive JSONEncode GroupActionsBehaviour, GroupedBehaviour derive JSONEncode HtmlTag, HtmlAttr //Can't derive TaskTree serialization because the damn thing contains functions //on unique states @!#$%!! JSONEncode{|TaskTree|} (TTMainTask a0 a1 a2 a3) = [JSONArray [JSONString "TTMainTask":JSONEncode{|*|} a0 ++ JSONEncode{|*|} a1 ++ JSONEncode{|*|} a2 ++ JSONEncode{|*|} a3]] JSONEncode{|TaskTree|} (TTSequenceTask a0 a1) = [JSONArray [JSONString "TTSequenceTask":JSONEncode{|*|} a0 ++ JSONEncode{|*|} a1]] JSONEncode{|TaskTree|} (TTParallelTask a0 a1 a2) = [JSONArray [JSONString "TTParallelTask":JSONEncode{|*|} a0 ++ JSONEncode{|*|} a1 ++ JSONEncode{|*|} a2]] JSONEncode{|TaskTree|} (TTGroupedTask a0 a1 a2 a3) = [JSONArray [JSONString "TTGroupedTask":JSONEncode{|*|} a0 ++ JSONEncode{|*|} a1 ++ JSONEncode{|*|} a3]] //DOES NOT INCLUDE a2 JSONEncode{|TaskTree|} (TTInteractiveTask a0 a1) = [JSONArray [JSONString "TTInteractiveTask":JSONEncode{|*|} a0 ++ JSONEncode{|*|} a1]] JSONEncode{|TaskTree|} (TTMonitorTask a0 a1) = [JSONArray [JSONString "TTMonitorTask":JSONEncode{|*|} a0 ++ JSONEncode{|*|} a1]] JSONEncode{|TaskTree|} (TTInstructionTask a0 a1) = [JSONArray [JSONString "TTInstructionTask":JSONEncode{|*|} a0 ++ JSONEncode{|*|} a1]] JSONEncode{|TaskTree|} (TTFinishedTask a0 a1) = [JSONArray [JSONString "TTFinishedTask":JSONEncode{|*|} a0 ++ JSONEncode{|*|} a1]] JSONEncode{|TaskTree|} (TTRpcTask a0 a1) = [JSONArray [JSONString "TTRpcTask":JSONEncode{|*|} a0 ++ JSONEncode{|*|} a1]] JSONEncode{|TaskInfoMenus|} (Menus menus) = [] JSONEncode{|TaskOutput|} fx NoOutput = [JSONNull] JSONEncode{|TaskOutput|} fx (UIOutput _) = [JSONString "User Interface Definition"] JSONEncode{|TaskOutput|} fx (JSONOutput v) = [v] JSONEncode{|InteractiveTask|} _ = [JSONNull] taskService :: !String !Bool ![String] !HTTPRequest *TSt -> (!HTTPResponse, !*TSt) taskService url html path req tst # (mbSessionErr,tst) = initSession sessionParam tst # (session,tst) = getCurrentSession tst = case path of //List tasks [] | isJust mbSessionErr = (serviceResponse html "Task list" listDescription url listParams (jsonSessionErr mbSessionErr), tst) # (processes,tst) = case session.Session.user of RootUser | userParam == "" = getProcessesForUser RootUser [Active] tst | otherwise = getProcessesForUser (NamedUser userParam) [Active] tst user = getProcessesForUser session.Session.user [Active] tst # items = taskItems processes # json = JSONObject [("success",JSONBool True),("tasks",toJSON items)] = (serviceResponse html "Task list" listDescription url listParams json, tst) //For debugging, list all tasks in the process table ["debug"] | isJust mbSessionErr = (serviceResponse html "Task debug list" listDebugDescription url debugParams (jsonSessionErr mbSessionErr), tst) # (processes,tst) = getProcesses [Active,Suspended,Finished,Excepted,Deleted] tst # json = JSONObject [("success",JSONBool True),("tasks",toJSON processes)] = (serviceResponse html "Task debug list" listDebugDescription url debugParams json, tst) //Start a new task (create a process) ["create"] | isJust mbSessionErr = (serviceResponse html "Create task" createDescription url createParams (jsonSessionErr mbSessionErr), tst) # (mbWorkflow, tst) = getWorkflowByName workflowParam tst # (json,tst) = case mbWorkflow of Nothing = (JSONObject [("success",JSONBool False),("error",JSONString "No such workflow")], tst) Just workflow # (taskId,_,_,tst) = createTaskInstance workflow.Workflow.thread True Nothing True True tst = (JSONObject [("success",JSONBool True),("taskId",JSONString taskId)], tst) = (serviceResponse html "Create task" createDescription url createParams json, tst) //Show task details of an individual task [taskId] | isJust mbSessionErr = (serviceResponse html "Task details" detailsDescription url detailsParams (jsonSessionErr mbSessionErr), tst) # (mbProcess, tst) = case session.Session.user of RootUser = getProcess taskId tst user = getProcessForUser user taskId tst = case mbProcess of Nothing = (notFoundResponse req, tst) Just proc //Events are posted as a list of triplets # events = case (fromJSON (fromString eventsParam)) of Just events = events Nothing = [] # (tree,tst) = calculateTaskTree taskId JSONTree events tst # task = JSONObject (taskProperties proc ++ [("parts", JSONArray (taskParts tree))]) # json = JSONObject [("success",JSONBool True),("task",task)] = (serviceResponse html "Task details" detailsDescription url detailsParams json, tst) //Dump the raw tasktree datastructure [taskId,"debug"] | isJust mbSessionErr = (serviceResponse html "Task debug" taskDebugDescription url debugParams (jsonSessionErr mbSessionErr), tst) # (mbProcess, tst) = getProcess taskId tst = case mbProcess of Nothing = (notFoundResponse req, tst) Just proc # treeType = case typeParam of "ui" = UITree "json" = JSONTree _ = SpineTree # (tree,tst) = calculateTaskTree taskId treeType [] tst # json = JSONObject [("success",JSONBool True),("task",toJSON proc),("tree",toJSON tree)] = (serviceResponse html "Task debug" taskDebugDescription url debugParams json, tst) //Show / Update task user interface definition [taskId,"tui"] | isJust mbSessionErr = (serviceResponse html "Task user interface" tuiDescription url tuiParams (jsonSessionErr mbSessionErr), tst) # (mbProcess, tst) = case session.Session.user of RootUser = getProcess taskId tst user = getProcessForUser user taskId tst = case mbProcess of Nothing = (notFoundResponse req, tst) Just proc # task = taskItem proc //Events are posted as a list of triplets # events = case (fromJSON (fromString eventsParam)) of Just events = events Nothing = [] # (tree,tst) = calculateTaskTree taskId UITree events tst # (timestamp,tst) = accWorldTSt time tst = case tree of (TTMainTask ti properties _ content) # tui = buildTaskPanel content session.Session.user # json = JSONObject [("success",JSONBool True),("task",toJSON task),("timestamp",toJSON timestamp),("tui",toJSON tui)] = (serviceResponse html "Task user interface" tuiDescription url tuiParams json, tst) _ # json = JSONObject [("success",JSONBool True),("task",toJSON task),("timestamp",toJSON timestamp),("tui",JSONNull)] = (serviceResponse html "Task user interface" tuiDescription url tuiParams json, tst) //Cancel / Abort / Delete the current task [taskId,"cancel"] | isJust mbSessionErr = (serviceResponse html "Cancel task" cancelDescription url detailsParams (jsonSessionErr mbSessionErr), tst) # (mbProcess, tst) = getProcess taskId tst = case mbProcess of Nothing = (notFoundResponse req, tst) Just proc // check whether the current user is allowed to cancel the task (user == manager) # (mbUProcess, tst) = case session.Session.user of RootUser = (Just proc,tst) user = getProcessForManager user proc.Process.taskId tst | not (isJust mbUProcess) = (serviceResponse html "Cancel task" cancelDescription url detailsParams (JSONObject [("success",JSONBool False),("error",JSONString "You do not have permission to cancel this task")]), tst) # tst = deleteTaskInstance proc.Process.taskId tst = (serviceResponse html "Cancel task" cancelDescription url detailsParams (JSONObject [("success",JSONBool True),("message",JSONString "Task deleted")]), tst) //Show / update Manager properties [taskId,"managerProperties"] | isJust mbSessionErr = (serviceResponse html "Manager properties" manPropsDescription url propParams (jsonSessionErr mbSessionErr), tst) # (mbProcess, tst) = case session.Session.user of RootUser = getProcess taskId tst user = getProcessForManager user taskId tst = case mbProcess of Nothing = (notFoundResponse req, tst) Just proc //Update properties if "update" is set # (json, tst) = case updateParam of "" = (JSONObject [("success",JSONBool True),("managerProperties",toJSON proc.Process.properties.managerProperties)], tst) update = case (fromJSON (fromString update)) of Just managerProperties # (ok,tst) = updateProcessProperties taskId (\p -> {p & managerProperties = managerProperties}) tst | ok = (JSONObject [("success",JSONBool True),("managerProperties",toJSON proc.Process.properties.managerProperties)], tst) = (JSONObject [("success",JSONBool False),("error",JSONString "Failed to update properties")],tst) _ = (JSONObject [("success",JSONBool False),("error",JSONString "Failed to parse update")],tst) = (serviceResponse html "Manager properties" manPropsDescription url propParams json, tst) [taskId,"managerProperties",_] # param = last path | isJust mbSessionErr = (serviceResponse html ("Manager property: "+++param) manPropDescription url propParams (jsonSessionErr mbSessionErr), tst) # (mbProcess, tst) = case session.Session.user of RootUser = getProcess taskId tst user = getProcessForManager user taskId tst = case mbProcess of Nothing = (notFoundResponse req, tst) Just proc # (json, tst) = case updateParam of "" = (getManagerProperty param proc.Process.properties.managerProperties,tst) update = updateManagerProperty param update proc tst # updateParam = "" //reset the update paramater = (serviceResponse html ("Manager property: "+++param) manPropDescription url propParams json, tst) //TODO: Worker properties & System properties //taskId/result -> show result of a finished in serialized form (to be implemented) //Show the result of a finished task as interface definition //TODO: Prevent access in case of a faulty user [taskId,"result","tui"] | isJust mbSessionErr = (serviceResponse html "Task result user interface" tuiResDescription url detailsParams (jsonSessionErr mbSessionErr), tst) # (mbProcess, tst) = getProcess taskId tst = case mbProcess of Nothing = (notFoundResponse req, tst) Just proc # task = taskItem proc # (tree,tst) = calculateTaskTree taskId UITree [] tst # tui = buildResultPanel tree # json = JSONObject [("success",JSONBool True),("task",toJSON task),("tui",toJSON tui)] = (serviceResponse html "Task result user interface" tuiResDescription url detailsParams json, tst) _ = (notFoundResponse req, tst) where sessionParam = paramValue "session" req userParam = paramValue "user" req createParams = [("session",sessionParam,True),("workflow",workflowParam,True)] workflowParam = paramValue "workflow" req listParams = [("session",sessionParam,True),("user",userParam,False)] debugParams = [("session",sessionParam,True),("type",typeParam,False)] typeParam = paramValue "type" req detailsParams = [("session",sessionParam,True),("events",eventsParam,False)] eventsParam = paramValue "events" req tuiParams = [("session",sessionParam,True),("events",eventsParam,False),("since",sinceParam,False)] sinceParam = paramValue "since" req propParams = [("session",sessionParam,True),("update",updateParam,False)] updateParam = paramValue "update" req jsonSessionErr (Just error) = JSONObject [("success",JSONBool False),("error", JSONString error)] taskItems processes = map taskItem processes taskItem process = process.Process.properties getManagerProperty :: !String !ManagerProperties -> JSONNode getManagerProperty param {worker,subject,priority,deadline,tags} = case param of "worker" = JSONObject [("success",JSONBool True),(param,toJSON worker)] "subject" = JSONObject [("success",JSONBool True),(param,toJSON subject)] "priority" = JSONObject [("success",JSONBool True),(param,toJSON priority)] "deadline" = JSONObject [("success",JSONBool True),(param,toJSON deadline)] "tags" = JSONObject [("success",JSONBool True),(param,toJSON tags)] _ = JSONObject [("success",JSONBool False),("error",JSONString ("Property "+++param+++" does not exist"))] updateManagerProperty :: !String !String !Process !*TSt -> (JSONNode,*TSt) updateManagerProperty param update proc tst # manProps = proc.Process.properties.managerProperties # (ok,newProps) = case param of "worker" = case fromJSON(fromString update) of Nothing = (False,manProps) Just upd = (True,{manProps & worker = upd}) "subject" = case fromJSON(fromString update) of Nothing = (False,manProps) Just upd = (True,{ManagerProperties | manProps & subject = upd}) "priority" = case fromJSON(fromString update) of Nothing = (False,manProps) Just upd = (True,{manProps & priority = upd}) "deadline" = case fromJSON(fromString update) of Nothing = (False,manProps) Just upd = (True,{manProps & deadline = upd}) "tags" = case fromJSON(fromString update) of Nothing = (False,manProps) Just upd = (True,{ManagerProperties | manProps & tags = upd}) _ = (False,manProps) = case ok of True # (ok,tst) = updateProcessProperties proc.Process.taskId (\p -> {p & managerProperties = newProps}) tst | ok = (getManagerProperty param newProps, tst) = (JSONObject [("success",JSONBool False),("error",JSONString "Failed to update properties")],tst) False = (JSONObject [("success", JSONBool False),("error", JSONString ("Cannot update '"+++param+++"' property"))],tst) taskProperties :: Process -> [(String,JSONNode)] taskProperties proc = case (toJSON proc.Process.properties) of (JSONObject fields) = fields taskParts :: TaskTree -> [JSONNode] taskParts (TTMainTask _ _ _ tree) = taskParts tree taskParts (TTSequenceTask _ trees) = flatten (map taskParts trees) taskParts (TTParallelTask _ _ trees) = flatten (map taskParts trees) taskParts (TTGroupedTask _ trees _ _) = flatten (map taskParts trees) taskParts (TTInteractiveTask ti val) = [JSONObject [("taskId",JSONString ti.TaskInfo.taskId),("type",JSONString "interactive"),("value",case val of JSONOutput json = json; _ = JSONNull)]] taskParts _ = [] listDescription :== "This service lists all tasks for the user of the provided session." listDebugDescription :== "This service dumps all information currently in the process database of running instances." detailsDescription :== "This service provides all meta-properties of a running task instance." createDescription :== "This service let's you create new instances of a workflow.
" +++ "The 'workflow' parameter is the path of a workflow (separated by slashes) as listed by the workflow directory service. " +++ "E.g. Foo/Bar/Baz" taskDebugDescription :== "This service dumps all information about a running task instance. Both its meta-properties and its task tree." manPropsDescription :== "This service displays the properties of a task instance that can be modified by a manager." manPropDescription :== "This service displays a single manager property." cancelDescription :== "This service let's you cancel (delete) a running task instance." tuiDescription :== "This yields an abstract user interface description for the current task." tuiResDescription :== "This yields an abstract user interface description that displays the current value of the task."