implementation module iTasks.Framework.WebService import StdList, StdBool, StdTuple import System.Time, Text, Text.JSON, Data.Map, Internet.HTTP, Data.Error import iTasks.Framework.Task, iTasks.Framework.TaskState, iTasks.Framework.TaskEval, iTasks.Framework.TaskStore import iTasks.Framework.UIDiff, iTasks.Framework.Util, iTasks.Framework.HtmlUtil, iTasks.Framework.Engine, iTasks.Framework.IWorld import iTasks.API.Core.SystemTypes //Flag for disabling use of the compiled version of the client javascript //only useful when doing work on the client framework IF_CLIENT_DEV yes no :== yes //The representation of the JSON service :: ServiceResponse :== [ServiceResponsePart] :: ServiceResponsePart = { taskId :: !String , value :: !JSONNode , actions :: ![String] } derive JSONEncode ServiceResponsePart //TODO: The upload and download mechanism used here is inherently insecure!!! // A smarter scheme that checks up and downloads, based on the current session/task is needed to prevent // unauthorized downloading of documents and DDOS uploading. webService :: !(HTTPRequest -> Task a) !ServiceFormat -> (!(HTTPRequest *IWorld -> (!HTTPResponse,!Maybe SessionId, !*IWorld)) ,!(HTTPRequest (Maybe {#Char}) SessionId *IWorld -> (!Maybe {#Char}, !Bool, !SessionId, !*IWorld)) ,!(HTTPRequest SessionId *IWorld -> *IWorld) ) | iTask a webService task defaultFormat = (reqFun task defaultFormat,dataFun,disconnectFun) where reqFun ::!(HTTPRequest -> Task a) !ServiceFormat HTTPRequest !*IWorld -> (!HTTPResponse,!Maybe SessionId, !*IWorld) | iTask a reqFun task defaultFormat req iworld=:{IWorld|application} //Check for uploads | hasParam "upload" req # uploads = toList req.arg_uploads | length uploads == 0 = (jsonResponse (JSONArray []),Nothing,iworld) # (documents, iworld) = createDocumentsFromUploads uploads iworld // response of uploads must use content-type "text/html" or else iframe upload of extjs does not work # rsp = jsonResponse (toJSON documents) = ({rsp & rsp_headers = put "Content-Type" "text/html" rsp.rsp_headers},Nothing,iworld) //Check for downloads | hasParam "download" req # (mbContent, iworld) = loadDocumentContent downloadParam iworld # (mbMeta, iworld) = loadDocumentMeta downloadParam iworld = case (mbContent,mbMeta) of (Just content,Just {Document|name,mime,size}) # headers = [("Status","200 OK"),("Content-Type", mime),("Content-Length", toString size),("Content-Disposition","attachment;filename=\"" +++ name +++ "\"")] = ({HTTPResponse|rsp_headers = fromList headers, rsp_data = content},Nothing,iworld) _ = (notFoundResponse req,Nothing,iworld) = case format req of //Serve start page WebApp = (appStartResponse application, Nothing, iworld) //Serve the user interface representation once, or if possible the diff between the current task GUI and a previous version JSONGui //Load or create session context and edit / evaluate # (mbResult, iworld) = case sessionParam of "" = createSessionTaskInstance (task req) event iworld sessionId = evalSessionTaskInstance sessionId event iworld # (json, iworld) = case mbResult of Error err = (JSONObject [("success",JSONBool False),("error",JSONString err)],iworld) Ok (ExceptionResult _ err,_,_,_) = (JSONObject [("success",JSONBool False),("error",JSONString err)], iworld) Ok (ValueResult (Value _ True) _ _ _,_,_,_) = (JSONObject ([("success",JSONBool True),("done",JSONBool True)]), iworld) Ok (ValueResult _ info curRep context,instanceNo,{SessionInfo|sessionId,lastEvent},updates) //Determine expiry date # (expiresIn,iworld) = getResponseExpiry instanceNo iworld # json = JSONObject [("success",JSONBool True) ,("session",JSONString sessionId) ,("expiresIn",toJSON expiresIn) ,("lastEvent",JSONInt lastEvent) ,("updates", encodeUIUpdates updates) ] = (json,iworld) _ = (JSONObject [("success",JSONBool False),("error",JSONString "Unknown exception")],iworld) = (jsonResponse json, Nothing, iworld) //Serve the task representation as a continuous stream of GUI update events. JSONGuiEventStream = case sessionParam of "" = (errorResponse "Event stream is only possible for existing sessions", Nothing, iworld) sessionId = case evalSessionTaskInstance sessionId event iworld of (Ok (ValueResult _ _ _ _,instanceNo,{SessionInfo|sessionId},updates),iworld) = (eventsResponse updates, Just sessionId, iworld) (_,iworld) = (errorResponse "Failed to initialize event stream", Nothing, iworld) //Serve the task in easily accessable JSON representation JSONService # (mbResult,iworld) = case sessionParam of "" = createSessionTaskInstance (task req) event iworld sessionId = evalSessionTaskInstance sessionId event iworld = case mbResult of Ok (ExceptionResult _ err,_,_,_) = (errorResponse err, Nothing, iworld) Ok (ValueResult (Value val True) _ _ _,_,_,_) = (jsonResponse (serviceDoneResponse val), Nothing, iworld) Ok (ValueResult _ _ (TaskRep def rep) _,_,_,_) = (jsonResponse (serviceBusyResponse rep (uiDefActions def) (toList (uiDefAttributes def))), Nothing, iworld) //Serve the task in a minimal JSON representation (only possible for non-parallel instantly completing tasks) JSONPlain # (mbResult,iworld) = createSessionTaskInstance (task req) event iworld = case mbResult of Ok (ExceptionResult _ err,_,_,_) = (errorResponse err, Nothing, iworld) Ok (ValueResult (Value val _) _ _ _,_,_,_) = (jsonResponse val, Nothing, iworld) _ = (errorResponse "Requested service format not available for this task", Nothing, iworld) //Error unimplemented type _ = (jsonResponse (JSONString "Unknown service format"), Nothing, iworld) where sessionParam = paramValue "session" req downloadParam = paramValue "download" req uploadParam = paramValue "upload" req eventNoParam = paramValue "eventNo" req eventNo = toInt eventNoParam editEventParam = paramValue "editEvent" req actionEventParam = paramValue "actionEvent" req focusEventParam = paramValue "focusEvent" req event = case (fromJSON (fromString editEventParam)) of Just (taskId,name,value) = EditEvent eventNo (fromString taskId) name value _ = case (fromJSON (fromString actionEventParam)) of Just (taskId,actionId) = ActionEvent eventNo (fromString taskId) actionId _ = case (fromJSON (fromString focusEventParam)) of Just taskId = FocusEvent eventNo (fromString taskId) _ = RefreshEvent (Just eventNo) dataFun :: HTTPRequest (Maybe {#Char}) !SessionId !*IWorld -> (!Maybe {#Char}, !Bool, !SessionId, !*IWorld) dataFun req _ sessionId iworld = case format req of JSONGuiEventStream # (messages,iworld) = getUIMessages sessionId iworld = case messages of [] = (Nothing,False,sessionId,iworld) _ = (Just (formatMessageEvents messages),False,sessionId,iworld) _ = (Nothing,True,sessionId,iworld) disconnectFun :: HTTPRequest SessionId !*IWorld -> *IWorld disconnectFun _ _ iworld = iworld //Util functions format req = case paramValue "format" req of "webapp" = WebApp "json-gui" = JSONGui "json-gui-events" = JSONGuiEventStream "json-service" = JSONService "json-plain" = JSONPlain _ = defaultFormat jsonResponse json = {HTTPResponse | rsp_headers = fromList [("Content-Type","text/json"),("Access-Control-Allow-Origin","*")], rsp_data = toString json} errorResponse msg = {HTTPResponse | rsp_headers = fromList [("Status", "500 Internal Server Error")], rsp_data = msg} serviceBusyResponse rep actions attributes = JSONObject [("status",JSONString "busy"),("parts",parts),("attributes",JSONObject [(k,JSONString v) \\ (k,v) <- attributes])] where parts = toJSON [{ServiceResponsePart|taskId = toString taskId, value = value, actions = findActions taskId actions} \\ {TaskPart | taskId = taskId, repKind = EditorRep value} <- rep] findActions match actions = [actionName action \\ {taskId,action,enabled} <- actions | enabled && taskId == match] serviceDoneResponse val = JSONObject [("status",JSONString "complete"),("value",val)] serviceErrorResponse e = JSONObject [("status",JSONString "error"),("error",JSONString e)] eventsResponse updates = {HTTPResponse | rsp_headers = fromList [("Content-Type","text/event-stream"),("Cache-Control","no-cache")] , rsp_data = formatMessageEvents [UIUpdates updates]} formatMessageEvents messages = join "" (map format messages) where format (UIUpdates updates) = "data: " +++ toString (encodeUIUpdates updates) +++ "\n\n" format (UIReset text) = "event: reset\ndata: " +++ text +++ "\n\n" appStartResponse appName = {newHTTPResponse & rsp_data = toString (appStartPage appName)} where appStartPage appName = HtmlTag [] [head,body] head = HeadTag [] [TitleTag [] [Text appName]: styles ++ scripts] body = BodyTag [] [] styles = [LinkTag [RelAttr "stylesheet", HrefAttr file, TypeAttr "text/css"] [] \\ file <- stylefiles] scripts = [ScriptTag [SrcAttr file, TypeAttr "text/javascript"] [] \\ file <- scriptfiles] stylefiles = [IF_CLIENT_DEV "bootstrap.css" "build/itwc/production/resources/itwc-all.css" ,"css/icons.css" ,"css/app.css" ,appName +++ ".css"] scriptfiles = (IF_CLIENT_DEV ["ext/ext-debug.js"] []) ++ ["app/taskeval/utils.js","app/taskeval/itask.js" //UGLY INCLUSION, MUST BE MERGED INTO ITWC FRAMEWORK ,"app/taskeval/builtin.js","app/taskeval/dynamic.js" ,"app/taskeval/sapl.js" ,"app/taskeval/db.js", "app/taskeval/debug.js" ,"app/taskeval/interface.js" ] ++ (IF_CLIENT_DEV ["app/app.js"] ["build/itwc/production/all-classes.js"]) createDocumentsFromUploads [] iworld = ([],iworld) createDocumentsFromUploads [(n,u):us] iworld # (mbD,iworld) = createDocument u.upl_filename u.upl_mimetype u.upl_content iworld | isError mbD = createDocumentsFromUploads us iworld # (ds,iworld) = createDocumentsFromUploads us iworld = ([fromOk mbD:ds],iworld)