implementation module TaskService import StdList, StdBool import Time, JSON import SystemTypes, Task, TaskContext, TaskEval, TUIDiff, TUIEncode, Util, HtmlUtil, Map import IWorld from ProcessDB import qualified class ProcessDB(..), instance ProcessDB IWorld from SessionDB import qualified class SessionDB(..), instance SessionDB IWorld from WorkflowDB import qualified class WorkflowDB(..), instance WorkflowDB IWorld derive bimap Maybe, (,) derive JSONEncode TUIDef, TUIDefContent, TUIUpdate, TUIIcon, TUIButton, TUIMenuButton, TUIMenu, TUIMenuItem, Hotkey derive JSONEncode TUIControlType derive JSONEncode TUIButtonControl, TUIListItem derive JSONEncode TUIContainer, TUIPanel, TUITabContainer, TUITabItem, TUIBorderContainer, TUIBorderItem, TUIListContainer, TUIGridControl, TUITree, TUIEditControl, TUIShowControl, TUIRadioChoice, TUICheckChoice, TUISize, TUIVAlign, TUIHAlign, TUIDirection, TUIMinSize, TUIMargins derive JSONDecode TUIDef, TUIDefContent, TUIUpdate, TUIIcon, TUIButton, TUIMenuButton, TUIMenu, TUIMenuItem, Hotkey derive JSONDecode TUIControlType derive JSONDecode TUIButtonControl, TUIListItem derive JSONDecode TUIContainer, TUIPanel, TUITabContainer, TUITabItem, TUIBorderContainer, TUIBorderItem, TUIListContainer, TUIGridControl, TUITree, TUIEditControl, TUIShowControl, TUIRadioChoice, TUICheckChoice, TUISize, TUIVAlign, TUIHAlign, TUIDirection, TUIMinSize, TUIMargins JSONEncode{|HtmlTag|} htm = [JSONString (toString htm)] taskService :: !(Task a) !HTTPRequest !*IWorld -> (!HTTPResponse, !*IWorld) | iTask a taskService task req iworld=:{IWorld|timestamp,application} = case showParam of "gui" | sessionParam == "" //Create and evaluate a new session context # (mbResult,iworld) = createSessionInstance task iworld = case mbResult of Error err = (response (JSONObject [("success",JSONBool False),("error",JSONString err)]), iworld) Ok (TaskException _ err,_) = (response (JSONObject [("success",JSONBool False),("error",JSONString err)]), iworld) Ok (TaskFinished _, sessionId) = (response (JSONObject [("success",JSONBool False),("error",JSONString "Task completed instantly")]), iworld) Ok (TaskBusy Nothing _ tree, sessionId) = (response (JSONObject [("success",JSONBool False),("error",JSONString "No tui definition available")]), iworld) Ok (TaskBusy (Just tui) actions _ , sessionId =: SessionProcess session) //Save user interface to enable incremental updates in later requests # tuiStoreId = toString sessionId +++ "-gui" # iworld = storeValue tuiStoreId tui iworld //Output user interface # json = JSONObject [("content",encodeTUIDefinition tui) ,("session",JSONString session) ,("timestamp",JSONInt (toInt timestamp))] = (response json, iworld) | otherwise # sessionId = SessionProcess sessionParam //Load previous user interface to enable incremental updates # tuiStoreId = toString sessionId +++ "-gui" # (mbPreviousTui,iworld) = loadValueAndTimestamp tuiStoreId iworld //Check if the version of the user interface the client has is still fresh # outdated = case mbPreviousTui of Just (_,previousTimestamp) = timestampParam <> "" && Timestamp (toInt timestampParam) < previousTimestamp Nothing = False //Determine possible edit and commit events # editEvent = case fromJSON (fromString editEventParam) of Just (target,path,value) // ignore edit events of outdated clients | not outdated || timestampParam == "" = Just (ProcessEvent (reverse (taskNrFromString target)) (path,value)) | otherwise = Nothing Nothing = Nothing # commitEvent = case fromJSON (fromString commitEventParam) of Just (target,action) // ignore commit events of outdated clients | not outdated || timestampParam == "" = Just (ProcessEvent (reverse (taskNrFromString target)) action) | otherwise = Nothing Nothing = Nothing //Evaluate existing session context # (mbResult,iworld) = evalSessionInstance sessionId editEvent commitEvent iworld # (json,iworld) = case mbResult of Error err = (JSONObject [("success",JSONBool False),("error",JSONString err)],iworld) Ok (TaskException _ err) = (JSONObject [("success",JSONBool False),("error",JSONString err)], iworld) Ok (TaskFinished _) = (JSONObject ([("success",JSONBool True),("done",JSONBool True)]), iworld) Ok (TaskBusy mbCurrentTui actions context) # json = case (mbPreviousTui,mbCurrentTui) of (Just (previousTui,previousTimestamp),Just currentTui) | previousTimestamp == Timestamp (toInt timestampParam) = JSONObject [("success",JSONBool True) ,("updates", encodeTUIUpdates (diffTUIDefinitions previousTui currentTui)) ,("timestamp",toJSON timestamp)] | otherwise = JSONObject [("success",JSONBool True) ,("content",encodeTUIDefinition currentTui) ,("warning",JSONString "The client is outdated. The user interface was refreshed with the most recent value.") ,("timestamp",toJSON timestamp)] (Nothing, Just currentTui) = JSONObject [("success",JSONBool True) ,("content", encodeTUIDefinition currentTui) ,("timestamp",toJSON timestamp)] _ = JSONObject [("success",JSONBool True),("done",JSONBool True)] //Store tui for later incremental requests # iworld = case mbCurrentTui of Just currentTui = storeValue tuiStoreId currentTui iworld Nothing = iworld = (json,iworld) _ = (JSONObject [("success",JSONBool False),("error",JSONString "Unknown exception")],iworld) = (response json, iworld) _ //Serve start page = (appStartResponse application, iworld) where showParam = paramValue "show" req sessionParam = paramValue "session" req timestampParam = paramValue "timestamp" req editEventParam = paramValue "editEvent" req commitEventParam = paramValue "commitEvent" req response json = {HTTPResponse | rsp_headers = fromList [("Content-Type","text/json")], rsp_data = toString json} taskServiceOld :: !String !String ![String] !HTTPRequest !*IWorld -> (!HTTPResponse, !*IWorld) taskServiceOld url format path req iworld=:{IWorld|timestamp} # html = format == "html" # (mbSession,iworld) = 'SessionDB'.restoreSession sessionParam iworld = case path of //List tasks [] | isError mbSession = (serviceResponse html "Task list" listDescription url listParams (jsonSessionErr mbSession), iworld) # (processes,iworld) = case (fromOk mbSession).user of RootUser | userParam == "" = 'ProcessDB'.getProcessesForUser RootUser [Running] [Active] iworld | otherwise = 'ProcessDB'.getProcessesForUser (NamedUser userParam) [Running] [Active] iworld user = 'ProcessDB'.getProcessesForUser (fromOk mbSession).user [Running] [Active] iworld # items = taskItems processes # json = JSONObject [("success",JSONBool True),("tasks",JSONArray items)] = (serviceResponse html "Task list" listDescription url listParams json, iworld) //For debugging, list all tasks in the process table ["debug"] | isError mbSession = (serviceResponse html "Task debug list" listDebugDescription url debugParams (jsonSessionErr mbSession), iworld) # (processes,iworld) = 'ProcessDB'.getProcesses [Running,Finished,Excepted,Deleted] [Active,Suspended] iworld # json = JSONObject [("success",JSONBool True),("tasks",toJSON processes)] = (serviceResponse html "Task debug list" listDebugDescription url debugParams json, iworld) //Start a new task (create a process) ["create"] | isError mbSession = (serviceResponse html "Create task" createDescription url createParams (jsonSessionErr mbSession), iworld) # (mbResult,iworld) = createTopInstance (toInt workflowParam) (fromOk mbSession).user (if (paramParam == "") Nothing (Just (fromString paramParam))) iworld # json = case mbResult of Error err = JSONObject [("success",JSONBool False),("error",JSONString err)] Ok (TaskException _ err,_) = JSONObject [("success",JSONBool False),("error",JSONString err)] Ok (_,taskNr) = JSONObject [("success",JSONBool True),("taskId",JSONInt (last taskNr))] = (serviceResponse html "Create task" createDescription url createParams json, iworld) //Show properties of an individual task without further evaluating it. [taskId] | isError mbSession = (serviceResponse html "Task details" detailsDescription url detailsParams (jsonSessionErr mbSession), iworld) # (mbProcess, iworld) = 'ProcessDB'.getProcess (processOf taskId) iworld = case mbProcess of Nothing = (notFoundResponse req, iworld) Just proc # json = JSONObject [("success",JSONBool True),("task",toJSON proc.Process.properties)] = (serviceResponse html "Task details" detailsDescription url detailsParams json, iworld) //Evaluates a workflow instance (does not require being logged in) [taskId,"refresh"] //Evaluate with //# (mbResult,iworld) = evaluateWorkflowInstance (processOf taskId) Nothing Nothing [] iworld # (mbResult,iworld) = evalTopInstance (taskNrFromString taskId) (fromOk mbSession).user Nothing Nothing iworld # json = case mbResult of Error err = JSONObject [("success",JSONBool False),("error",JSONString err)] Ok (TaskException _ err) = JSONObject [("success",JSONBool False),("error",JSONString err)] _ = JSONObject [("success",JSONBool True)] = (serviceResponse html "Task details" refreshDescription url [] json, iworld) //Dump the raw task context datastructure [taskId,"debug"] | isError mbSession = (serviceResponse html "Task debug" taskDebugDescription url debugParams (jsonSessionErr mbSession), iworld) //# (mbResult,iworld) = evaluateWorkflowInstance (processOf taskId) Nothing Nothing [] iworld # (mbResult,iworld) = evalTopInstance (taskNrFromString taskId) (fromOk mbSession).user Nothing Nothing iworld # json = case mbResult of Error err = JSONObject [("success",JSONBool False),("error",JSONString err)] Ok (TaskBusy _ _ context) = JSONObject [("success",JSONBool False),("tree",toJSON context)] Ok (TaskFinished _) = JSONObject [("success",JSONBool True),("result",JSONString "finished")] Ok (TaskException _ err) = JSONObject [("success",JSONBool False),("error",JSONString err)] = (serviceResponse html "Task debug" taskDebugDescription url debugParams json, iworld) //Show / Update task user interface definition [taskId,"tui"] | isError mbSession = (serviceResponse html "Task user interface" tuiDescription url tuiParams (jsonSessionErr mbSession), iworld) //Load previous user interface to enable incremental updates # tuiStoreId = "Process-" +++ taskId +++ "-tui" # (mbPreviousTui,iworld) = loadValueAndTimestamp tuiStoreId iworld //Check if the version of the user interface the client has is still fresh # outdated = case mbPreviousTui of Just (_,previousTimestamp) = timestampParam <> "" && Timestamp (toInt timestampParam) < previousTimestamp Nothing = False //Determine possible edit and commit events # editEvent = case fromJSON (fromString editEventParam) of Just (target,path,value) // ignore edit events of outdated clients | not outdated || timestampParam == "" = Just (ProcessEvent (reverse (taskNrFromString target)) (path,value)) | otherwise = Nothing Nothing = Nothing # commitEvent = case fromJSON (fromString commitEventParam) of Just (target,action) // ignore commit events of outdated clients | not outdated || timestampParam == "" = Just (ProcessEvent (reverse (taskNrFromString target)) action) | otherwise = Nothing Nothing = Nothing //We need the current timestamp to include in the response # (timestamp,iworld) = getTimestamp iworld //Evaluate the workflow instance //# tuiTaskNr = taskNrFromString taskId //# (mbResult,iworld) = evaluateWorkflowInstance (processOf taskId) editEvent commitEvent tuiTaskNr iworld # (mbResult,iworld) = evalTopInstance (taskNrFromString taskId) (fromOk mbSession).user editEvent commitEvent iworld # (json,iworld) = case mbResult of Error err = (JSONObject [("success",JSONBool False),("error",JSONString err)],iworld) Ok (TaskBusy mbCurrentTui actions context) //Determine content or updates # tui = case (mbPreviousTui,mbCurrentTui) of (Just (previousTui,previousTimestamp),Just currentTui) | previousTimestamp == Timestamp (toInt timestampParam) = JSONObject [("updates",encodeTUIUpdates (diffTUIDefinitions previousTui currentTui))] | otherwise = JSONObject [("content",encodeTUIDefinition currentTui)] (Nothing, Just currentTui) = JSONObject [("content", encodeTUIDefinition currentTui)] _ = JSONString "done" //Store tui for later incremental requests # iworld = case mbCurrentTui of Just currentTui = storeValue tuiStoreId currentTui iworld Nothing = iworld //Build output structure # json = JSONObject [("success",JSONBool True) ,("timestamp",toJSON timestamp) ,("tui",tui) :if outdated [("warning",JSONString "The client is outdated. The user interface was refreshed with the most recent value.")] [] ] = (json, iworld) Ok (TaskFinished _) = (JSONObject ([("success",JSONBool True),("timestamp",toJSON timestamp),("tui",JSONString "done")]), iworld) Ok (TaskException _ err) = (JSONObject [("success",JSONBool False),("error",JSONString err)], iworld) _ = (JSONObject [("success",JSONBool False),("error",JSONString "Unknown exception")],iworld) = (serviceResponse html "Task user interface" tuiDescription url tuiParams json,iworld) //Cancel / Abort / Delete the current task [taskId,"cancel"] | isError mbSession = (serviceResponse html "Cancel task" cancelDescription url detailsParams (jsonSessionErr mbSession), iworld) | length (taskNrFromString taskId) > 1 // don't delete detached = (serviceResponse html "Cancel task" cancelDescription url detailsParams (JSONObject [("success",JSONBool False),("error",JSONString "Cannot delete detached process")]), iworld) # (iworld) = 'ProcessDB'.deleteProcess (processOf taskId) iworld = (serviceResponse html "Cancel task" cancelDescription url detailsParams (JSONObject [("success",JSONBool True),("message",JSONString "Task deleted")]), iworld) _ = (notFoundResponse req, iworld) where showParam = paramValue "show" req sessionParam = paramValue "session" req userParam = paramValue "user" req timestampParam = paramValue "timestamp" req createParams = [("session",sessionParam,True),("workflow",workflowParam,True),("parameter",paramParam,False)] workflowParam = paramValue "workflow" req paramParam = paramValue "parameter" req listParams = [("session",sessionParam,True),("user",userParam,False)] debugParams = [("session",sessionParam,True),("type",typeParam,False)] typeParam = paramValue "type" req detailsParams = [("session",sessionParam,True),("editEvent",editEventParam,False),("commitEvent",commitEventParam,False)] editEventParam = paramValue "editEvent" req commitEventParam = paramValue "commitEvent" req tuiParams = [("session",sessionParam,True),("editEvent",editEventParam,False),("commitEvent",commitEventParam,False),("since",sinceParam,False)] sinceParam = paramValue "since" req propParams = [("session",sessionParam,True),("update",updateParam,False)] updateParam = paramValue "update" req jsonSessionErr (Error error) = JSONObject [("success",JSONBool False),("error", JSONString error)] //TODO: Refactor this mechanism. //It is a bit of a shame that the tree structure is flattened here and //then reconstructed again on the client... //And very ugly and inefficient :) taskItems processes = items Nothing processes where items parent processes = flatten (map (item parent) processes) item parent process # json = case parent of Nothing = toJSON process.Process.properties Just taskId # json = toJSON process.Process.properties = addParent taskId json = [json: items (Just process.Process.properties.systemProperties.SystemProperties.taskId) process.Process.subprocesses] addParent taskId (JSONObject [("taskProperties",taskProperties),("managerProperties",managerProperties),("systemProperties",JSONObject systemProperties)]) = JSONObject [("taskProperties",taskProperties),("managerProperties",managerProperties),("systemProperties",JSONObject [("parent",JSONString taskId):systemProperties])] processOf taskId = case taskNrFromString taskId of [] = WorkflowProcess 0 taskNr = WorkflowProcess (last taskNr) taskProperties :: Process -> [(String,JSONNode)] taskProperties proc = case (toJSON proc.Process.properties) of (JSONObject fields) = fields getTimestamp :: !*IWorld -> (!Timestamp,!*IWorld) getTimestamp iworld=:{IWorld|timestamp} = (timestamp,iworld) 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." cancelDescription :== "This service let's you cancel (delete) a running task instance." tuiDescription :== "This yields an abstract user interface description for the current task." refreshDescription :== "This service recalculates the task tree of a running task instance."