implementation module WebService

import StdList, StdBool, StdTuple
import Time, JSON_NG
import SystemTypes, Task, TaskState, TaskEval, TaskStore, UIDiff, Util, HtmlUtil, Map
import Engine, IWorld

//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, !*IWorld) | iTask a
webService task defaultFormat req iworld=:{IWorld|timestamp,application}
	//Check for uploads
	| hasParam "upload" req
		# uploads = toList req.arg_uploads
		| length uploads == 0
			= (jsonResponse (JSONArray []),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},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},iworld)
			_
				= (notFoundResponse req,iworld)
	= case format of
		//Serve start page
		WebApp	
			=  (appStartResponse application, iworld)
		//Serve the user interface representations
		JSONGui
			//Load or create session context and edit / evaluate
			# (mbResult, mbPrevUI, iworld)	= case sessionParam of
				""	
					# (mbResult, iworld) = createSessionInstance (task req) RefreshEvent iworld
					= (mbResult, Nothing, iworld)
				sessionId
					//Check if there is a previous tui definition and check if it is still current
					# (mbPrevUI,iworld)		= loadPrevUI sessionId guiVersion iworld
					# (mbResult, iworld) 	= evalSessionInstance sessionId event iworld
					= (mbResult,mbPrevUI,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 _ Stable) _ _ _,_,_)
						= (JSONObject ([("success",JSONBool True),("done",JSONBool True)]), iworld)
					Ok (ValueResult _ info curRep context,_,sessionId)
						# json = case (mbPrevUI,curRep) of
							(Nothing, TaskRep def _)
								= JSONObject [("success",JSONBool True)
											 ,("session",JSONString sessionId)
											 ,("expiresIn",toJSON info.TaskInfo.expiresIn)
											 ,("content", encodeUIDefinition def)
											 ,("version",toJSON guiVersion)]
							
							(Just prevUI, TaskRep def _)
									= JSONObject [("success",JSONBool True)
												 ,("session",JSONString sessionId)
												 ,("expiresIn",toJSON info.TaskInfo.expiresIn)
												 ,("updates", encodeUIUpdates (diffUIDefinitions prevUI def event))
												 ,("version",toJSON guiVersion)]
							
							_
								= JSONObject [("success",JSONBool True),("done",JSONBool True)]
						//Store gui for later incremental requests
						# iworld = case curRep of
							TaskRep def _	= storeCurUI sessionId guiVersion def iworld
							_				= iworld
						= (json,iworld)
					_
						= (JSONObject [("success",JSONBool False),("error",JSONString  "Unknown exception")],iworld)
			= (jsonResponse json, iworld)
		//Serve the task in easily accessable JSON representation
		JSONService
			# (mbResult,iworld)	= case sessionParam of
				""	= createSessionInstance (task req) RefreshEvent iworld
				sessionId
					= evalSessionInstance sessionId RefreshEvent iworld
			= case mbResult of
				Ok (ExceptionResult _ err,_,_)
					= (errorResponse err, iworld)
				Ok (ValueResult (Value val Stable) _ _ _,_,_)
					= (jsonResponse (serviceDoneResponse val), iworld)
				Ok (ValueResult _ _ (TaskRep {UIDef|actions,attributes} rep) _,_,_)
					= (jsonResponse (serviceBusyResponse rep actions (toList attributes)), iworld)
		//Serve the task in a minimal JSON representation (only possible for non-parallel instantly completing tasks)
		JSONPlain
			# (mbResult,iworld) = createSessionInstance (task req) RefreshEvent iworld
			= case mbResult of
				Ok (ExceptionResult _ err,_,_)
					= (errorResponse err, iworld)
				Ok (ValueResult (Value val _) _ _ _,_,_)
					= (jsonResponse val, iworld)
				_
					= (errorResponse "Requested service format not available for this task", iworld)
		//Error unimplemented type
		_
			= (jsonResponse (JSONString "Unknown service format"), iworld)	
where
	format			= case formatParam of
		"webapp"			= WebApp
		"json-gui"			= JSONGui
		"json-service"		= JSONService
		"json-plain"		= JSONPlain
		_					= defaultFormat

	formatParam			= paramValue "format" req

	sessionParam		= paramValue "session" req
	downloadParam		= paramValue "download" req
	uploadParam			= paramValue "upload" req
	versionParam		= paramValue "version" req

	editEventParam		= paramValue "editEvent" req
	actionEventParam	= paramValue "actionEvent" req
	focusEventParam		= paramValue "focusEvent" req
	
	event = case (fromJSON (fromString editEventParam)) of
		Just (taskId,name,value)	= EditEvent (fromString taskId) name value
		_	= case (fromJSON (fromString actionEventParam)) of
			Just (taskId,actionId)	= ActionEvent (fromString taskId) actionId
			_	= case (fromJSON (fromString focusEventParam)) of
				Just taskId			= FocusEvent (fromString taskId)
				_					= RefreshEvent
	
	guiVersion			= toInt versionParam

	jsonResponse json
		= {HTTPResponse | rsp_headers = fromList [("Content-Type","text/json")], 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} \\ (taskId,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)]

	appStartResponse appName = {newHTTPResponse & rsp_data = toString (appStartPage appName)}

	appStartPage appName = HtmlTag [] [head,body]
	where
		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 = ["lib/extjs-4.1.0/resources/css/ext-all-gray.css"
					 ,"css/icons.css"
					 ,"css/app.css"
					 ,appName +++ ".css"]
		scriptfiles = ["lib/extjs-4.1.0/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/sapl.js",
					   "app/taskeval/db.js", "app/taskeval/debug.js",				   
					   "app.js"]
		//scriptfiles = ["/lib/ext-4.1.0/ext.js","/app-all.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)