implementation module WebService

import StdList, StdBool
import Time, JSON
import SystemTypes, Task, TaskContext, TaskEval, TaskStore, TUIDiff, TUIEncode, Util, HtmlUtil, Map
import Engine, IWorld

//The representation of the JSON service
:: ServiceResponse :== [ServiceResponsePart]
:: ServiceResponsePart =
	{ taskId	:: !String
	, partId	:: !Int
	, value		:: !JSONNode
	, actions	:: ![String]
	}
	
derive JSONEncode ServiceResponsePart

webService :: !(Task a) !ServiceFormat !HTTPRequest !*IWorld -> (!HTTPResponse, !*IWorld) | iTask a
webService task defaultFormat req iworld=:{IWorld|timestamp,application}
	= 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, mbPrevTui, iworld)	= case sessionParam of
				""	
					# (mbResult, iworld) = createSessionInstance task Nothing Nothing True iworld
					= (mbResult, Error "Fresh session, no previous user interface", iworld)
				sessionId
					//Check if there is a previous tui definition and check if it is still current
					# (mbPreviousTui,iworld)	= loadTaskTUI sessionId iworld
					//Check if the version of the user interface the client has is still fresh
					# outdated = case mbPreviousTui of
						Ok (_,prevGuiVersion)		= guiVersion < prevGuiVersion
						Error _						= False
					| outdated
						# (mbResult, iworld) = evalSessionInstance sessionId Nothing Nothing True iworld
						= (mbResult,mbPreviousTui,iworld)
					| otherwise
						# (mbResult, iworld) = evalSessionInstance sessionId editEvent commitEvent True iworld
						= (mbResult,mbPreviousTui,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 (TaskStable _ _ _,_)
						= (JSONObject ([("success",JSONBool True),("done",JSONBool True)]), iworld)
					Ok (TaskUnstable _ mbCurrentTui context,sessionId)
						# json = case (mbPrevTui,mbCurrentTui) of
							(Ok (previousTui,prevGuiVersion),TUIRep (_,Just currentTui,actions,attributes))
								| prevGuiVersion == guiVersion - 1 //The stored version, is exactly one less then the current version 
									= JSONObject [("success",JSONBool True)
												 ,("session",JSONString sessionId)
												 ,("updates", encodeTUIUpdates (diffTUIDefinitions previousTui currentTui))
												 ,("timestamp",toJSON timestamp)]
								| otherwise
									= JSONObject [("success",JSONBool True)
												 ,("session",JSONString sessionId)
												 ,("content",encodeTUIDefinition currentTui)
												 ,("warning",JSONString "The client is out of sync. The user interface was refreshed with the most recent value.")
												 ,("timestamp",toJSON timestamp)]
							(_, TUIRep (_,Just currentTui,actions,attributes))
								= JSONObject [("success",JSONBool True)
											 ,("session",JSONString sessionId)
											 ,("content", encodeTUIDefinition currentTui)
											 ,("timestamp",toJSON timestamp)]
							_
								= JSONObject [("success",JSONBool True),("done",JSONBool True)]
						//Store gui for later incremental requests
						# iworld = case mbCurrentTui of
							TUIRep (_,Just currentTui,_,_)	= storeTaskTUI sessionId currentTui guiVersion 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 Nothing Nothing False iworld
				sessionId
					= evalSessionInstance sessionId Nothing Nothing False iworld
			= case mbResult of
				Ok (TaskException _ err,_)
					= (errorResponse err, iworld)
				Ok (TaskStable val _ _,_)
					= (jsonResponse (serviceDoneResponse val), iworld)
				Ok (TaskUnstable _ (ServiceRep (rep,actions,attributes)) _,_)
					= (jsonResponse (serviceBusyResponse rep actions attributes), iworld)
				Ok (TaskUnstable _ _ _,_)
					= (errorResponse "Requested service format not available for this task", iworld)
		//Serve the task in a minimal JSON representation (only possible for non-parallel instantly completing tasks)
		JSONPlain
			//HACK: REALLY REALLY REALLY UGLY THAT IT IS NECCESARY TO EVAL TWICE
			# (mbResult,iworld) = createSessionInstance task Nothing Nothing False iworld
			# (mbResult,iworld) = case mbResult of
				(Ok (_,sessionId))	= evalSessionInstance sessionId luckyEdit luckyCommit False iworld
				(Error e)			= (Error e,iworld)
			= case mbResult of
				Ok (TaskException _ err,_)
					= (errorResponse err, iworld)
				Ok (TaskStable val _ _,_)
					= (plainDoneResponse 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
	editEvent			= case (fromJSON (fromString editEventParam)) of
		Just (task,path,value)	= Just (TaskEvent (fromString task) (path,value))
		_						= Nothing
	commitEventParam	= paramValue "commitEvent" req
	commitEvent			= case (fromJSON (fromString commitEventParam)) of
		Just (task,action)		= Just (TaskEvent (fromString task) action)
		_						= Nothing

	guiVersion			= toInt versionParam
	
	//Parse the body of the request as JSON message
	(luckyEdit,luckyCommit) = if(req.req_data == "")
		(Nothing,Nothing)	
		(Just (LuckyEvent ("0",fromString req.req_data)), Just (LuckyEvent ""))
	
	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, partId = partId, value = value, actions = findActions taskId actions} \\ (taskId,partId,value) <- rep]
		findActions taskId actions
			= [actionName action \\ (task,action,enabled) <- actions | enabled && task == taskId]
	
	serviceDoneResponse (Container val :: Container a a)
		= JSONObject [("status",JSONString "complete"),("value",toJSON val)]
	serviceDoneResponse _
		= serviceErrorResponse "Corrupt result value"
	serviceErrorResponse e
		= JSONObject [("status",JSONString "error"),("error",JSONString e)]
		
	plainDoneResponse (Container val :: Container a a)
		= jsonResponse (toJSON val)
	plainDoneResponse _
		= errorResponse "Corrupt result value"

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

	appStartPage appName = HtmlTag [] [head,body]
	where
		head = HeadTag [] [TitleTag [] [Text "Loading..."]: 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/ext-4.0.2a/resources/css/ext-all-gray.css"
					 ,"/css/main.css"
					 ,appName +++ ".css"]
		scriptfiles = ["/lib/ext-4.0.2a/ext-debug.js","/app.js"]
		//scriptfiles = ["/lib/ext-4.0.2a/ext.js","/app-all.js"]