implementation module iTasks.Framework.WebService

import StdList, StdBool, StdTuple, StdArray
import Data.Maybe, Data.Functor, Data.List, Data.Map

import System.Time, Text, Text.JSON, 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.Types
import Crypto.Hash.SHA1, Text.Encodings.Base64

from HttpUtil import http_addRequestData, http_parseArguments

DEFAULT_THEME :== "gray"

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

:: NetTaskState
    = NTIdle String Timestamp
    | NTReadingRequest HttpReqState
	| NTProcessingRequest HTTPRequest ConnectionType

:: HttpReqState =
    { request       :: HTTPRequest
    , method_done   :: Bool
    , headers_done  :: Bool
    , data_done     :: Bool
    , error         :: Bool
    }

derive JSONEncode ServiceResponsePart

// Websocket task access messages
:: WSCReq
    = ReqStartSession !InstanceNo
    | TaskEvent !Event

:: WSCRsp
    = AckStartSession !InstanceNo
    | TaskUpdates !InstanceNo ![UIUpdate]

//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 :: !String !(HTTPRequest -> Task a) !ServiceFormat ->
						 (!(String -> Bool)
                         ,!(HTTPRequest *IWorld -> (!HTTPResponse,!Maybe ConnectionType, !*IWorld))
						 ,!(HTTPRequest (Maybe {#Char}) ConnectionType *IWorld -> (![{#Char}], !Bool, !ConnectionType, !*IWorld))
						 ,!(HTTPRequest ConnectionType *IWorld -> *IWorld)
						 ) | iTask a
webService url task defaultFormat = (matchFun url,reqFun` url task defaultFormat,dataFun,disconnectFun)
where
    matchFun :: String String -> Bool
    matchFun matchUrl reqUrl = startsWith matchUrl reqUrl && isTaskUrl (reqUrl % (size matchUrl,size reqUrl))
    where
        isTaskUrl "" = True
        isTaskUrl s = case dropWhile ((==)"") (split "/" s) of  // Ignore slashes at the beginning of the path
            ["gui-stream"]      = True                          // Updates stream for multiple instances
            [instanceNo,_]      = toInt instanceNo > 0          // {instanceNo}/{instanceKey}
            [instanceNo,_,_]    = toInt instanceNo > 0          // {instanceNo}/{instanceKey}/{view}
            _                   = False

	reqFun` :: !String !(HTTPRequest -> Task a) !ServiceFormat HTTPRequest !*IWorld -> (!HTTPResponse,!Maybe ConnectionType, !*IWorld) | iTask a
	reqFun` url task defaultFormat req iworld=:{server}
		# server_url = "//" +++ req.server_name +++ ":" +++ toString req.server_port
		= reqFun url task defaultFormat req {IWorld|iworld & server = {server & serverURL = server_url}}

	reqFun :: !String !(HTTPRequest -> Task a) !ServiceFormat HTTPRequest !*IWorld -> (!HTTPResponse,!Maybe ConnectionType, !*IWorld) | iTask a
	reqFun url task defaultFormat req iworld=:{IWorld|server={serverName,customCSS},config}
		//Check for uploads
		| hasParam "upload" req
			# uploads = toList req.arg_uploads
			| length uploads == 0
				= (jsonResponse (JSONArray []),Nothing,iworld)
			# (documents, iworld) = createDocumentsFromUploads uploads iworld
			= (jsonResponse (toJSON documents),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	= [("Content-Type", mime),("Content-Length", toString size),("Content-Disposition","attachment;filename=\"" +++ name +++ "\"")]
					= ({okResponse & rsp_headers = headers, rsp_data = content},Nothing,iworld)
				_
					= (notFoundResponse req,Nothing,iworld)
        //Check for WebSocket upgrade headers
        | (get "Upgrade" req.req_headers) =:(Just "websocket") && isJust (get "Sec-WebSocket-Key" req.req_headers)
            # secWebSocketKey       = fromJust (get "Sec-WebSocket-Key" req.req_headers)
            # secWebSocketAccept    = webSocketHandShake secWebSocketKey
            //Create handshake response
            # headers = [("Upgrade","websocket"), ("Connection","Upgrade")
                        ,("Sec-WebSocket-Accept",secWebSocketAccept),("Sec-WebSocket-Protocol","itwc")]
            = ({newHTTPResponse 101 "Switching Protocols" & rsp_headers = headers, rsp_data = ""}, Just (WebSocketConnection []),iworld)
        | urlSpec == ""
            = case defaultFormat of
			    (WebApp	opts)
                    = case createTaskInstance (task req) iworld of
                        (Error err, iworld)
				            = (errorResponse err, Nothing, iworld)
                        (Ok (instanceNo,instanceKey),iworld)
				            = (itwcStartResponse url instanceNo instanceKey (theme opts) serverName customCSS, Nothing, iworld)
                JSONPlain
                    = case createTaskInstance (task req) iworld of
                        (Error err, iworld)
				            = (errorResponse err, Nothing, iworld)
                        (Ok (instanceNo,instanceKey),iworld)
                            = case evalTaskInstance instanceNo event iworld of
                                (Error err,iworld)            = (errorResponse err, Nothing, iworld)
					            (Ok (_,Value val _,_),iworld) = (jsonResponse val, Nothing, iworld)
					            (Ok (_,NoValue,_),iworld)     = (jsonResponse JSONNull, Nothing, iworld)
			    _
				    = (jsonResponse (JSONString "Unknown service format"), Nothing, iworld)
        | otherwise
            = case dropWhile ((==)"") (split "/" urlSpec) of
                ["gui-stream"]
                    //Stream messages for multiple instances
                    # (messages,iworld)	= popUIUpdates instances iworld //TODO: Check keys
                    = (eventsResponse messages, Just (EventSourceConnection instances), iworld)
                [instanceNo,instanceKey]
                    = (itwcStartResponse url instanceNo instanceKey (theme []) serverName customCSS, Nothing, iworld)
                [instanceNo,instanceKey,"gui"]
                    //Load task instance and edit / evaluate
                    # instanceNo         = toInt instanceNo
                    # (mbResult, iworld) = evalTaskInstance instanceNo event iworld
                    # (json, iworld) = case mbResult of
                        Error err
					        = (JSONObject [("error",JSONString err)],iworld)
                        Ok (lastEventNo,value,updates)
                            //Determine expiry date	
                            # (expiresIn,iworld) = getResponseExpiry instanceNo iworld
                            # json	= JSONObject [("instance",JSONInt instanceNo)
                                                 ,("expiresIn",toJSON expiresIn)
                                                 ,("lastEvent",JSONInt lastEventNo)
                                                 ,("updates",encodeUIUpdates updates)
                                                 ]
                            = (json,iworld)
                        _
					        = (JSONObject [("success",JSONBool False),("error",JSONString  "Unknown exception")],iworld)
                    = (jsonResponse json, Nothing, iworld)
                //Stream messages for a specific instance
                [instanceNo,instanceKey,"gui-stream"]
                    # (messages,iworld)	= popUIUpdates [toInt instanceNo] iworld	
                    = (eventsResponse messages, Just (EventSourceConnection [toInt instanceNo]), iworld)
                _
				    = (errorResponse "Requested service format not available for this task", Nothing, iworld)
	    where
            urlSpec             = req.req_path % (size url,size req.req_path)

		    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
            resetEventParam     = paramValue "resetEvent" req

            instances = filter (\i. i > 0) (map toInt (split "," (paramValue "instances" req)))

            theme [Theme name:_] = name
            theme _              = DEFAULT_THEME

		    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)
					    _   = if (resetEventParam == "") (RefreshEvent (Just eventNo)) ResetEvent

        webSocketHandShake key = base64Encode digest
        where
            (SHA1Digest digest) = sha1StringDigest (key+++"258EAFA5-E914-47DA-95CA-C5AB0DC85B11")

	dataFun :: HTTPRequest (Maybe {#Char}) !ConnectionType !*IWorld -> (![{#Char}], !Bool, !ConnectionType, !*IWorld)
    dataFun req mbData (WebSocketConnection instances) iworld
        = (maybe [] (\d -> [d]) mbData,False,(WebSocketConnection instances),iworld) //TEMPORARY ECHO WEBSOCKET
	dataFun req _ (EventSourceConnection instances) iworld
        # (messages,iworld)	= popUIUpdates instances iworld	
		= case messages of
			[]	= ([],False,(EventSourceConnection instances),iworld)
			_	= ([formatMessageEvents messages],False,(EventSourceConnection instances),iworld)

    disconnectFun :: HTTPRequest !ConnectionType !*IWorld -> *IWorld
	disconnectFun _ _ iworld = iworld

	jsonResponse json
		= {okResponse & rsp_headers = [("Content-Type","text/json"),("Access-Control-Allow-Origin","*")], rsp_data = toString json}
			
	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)]

	eventsResponse messages
		= {okResponse &   rsp_headers = [("Content-Type","text/event-stream"),("Cache-Control","no-cache")]
                        , rsp_data = formatMessageEvents messages}
	
	formatMessageEvents messages = concat (map format messages)
    where
        format (instanceNo,updates) = "data: {\"instance\":" +++toString instanceNo+++",\"updates\":" +++ toString (encodeUIUpdates updates) +++ "}\n\n"

	itwcStartResponse path instanceNo instanceKey theme appName customCSS = {okResponse & rsp_data = toString itwcStartPage}
	where
		itwcStartPage = HtmlTag [] [head,body]
		head = HeadTag [] [MetaTag [CharsetAttr "UTF-8"] []
                          ,MetaTag [NameAttr "viewport",ContentAttr "width=device-width"] []
                          ,MetaTag [NameAttr "mobile-web-app-capable",ContentAttr "yes"] []
                          ,TitleTag [] [Text appName], startUrlScript : styles ++ scripts]
		body = BodyTag [] []

        startUrlScript = ScriptTag [TypeAttr "text/javascript"]
            [RawText "window.itwc = {};"
            ,RawText ("itwc.START_INSTANCE_NO = "+++toString instanceNo+++";")
            ,RawText ("itwc.START_INSTANCE_KEY = \""+++instanceKey+++"\";")
            ]
		styles = [LinkTag [RelAttr "stylesheet", HrefAttr file, TypeAttr "text/css"] [] \\ file <- stylefiles]
		scripts = [ScriptTag [SrcAttr file, TypeAttr "text/javascript"] [] \\ file <- scriptfiles]
		
		stylefiles =
            ["itwc-theme-"+++theme+++"/itwc-theme.css"
			,"css/icons.css"
			,"css/app.css"
			: if customCSS [appName +++ ".css"] []]

        scriptfiles =
            ["/app/taskeval/utils.js","/app/taskeval/itask.js" //TODO: Clean up SAPL mixed mess
			,"/app/taskeval/builtin.js"
			,"/app/taskeval/dynamic.js"
			,"/app/taskeval/sapl-rt.js", "/app/taskeval/sapl-support.js"
			,"/app/taskeval/db.js", "/app/taskeval/debug.js"
			,"/app/taskeval/interface.js"
            ,"/itwc.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)

httpServer :: !Int !Int ![(!String -> Bool
				,!Bool
				,!(HTTPRequest *IWorld -> (!HTTPResponse,!Maybe ConnectionType, !*IWorld))
				,!(HTTPRequest (Maybe {#Char}) ConnectionType *IWorld -> (![{#Char}], !Bool, !ConnectionType, !*IWorld))
				,!(HTTPRequest ConnectionType *IWorld -> *IWorld)
				)] -> ConnectionTask
httpServer port keepAliveTime requestProcessHandlers = ConnectionTask init eval close
where
    init host iworld=:{IWorld|world}
        # (ts,world) = time world
        = ([],False,dynamic (NTIdle host ts),{IWorld|iworld & world = world})

	eval mbData (connState=:(NTProcessingRequest request localState) :: NetTaskState) env
		//Select handler based on request path
		= case selectHandler request requestProcessHandlers of
			Just (_,_,_,handler,_)
				# (mbData,done,localState,env=:{IWorld|world}) = handler request mbData localState env
				| done && isKeepAlive request	//Don't close the connection if we are done, but keepalive is enabled
					# (now,world)       = time world
					= (mbData, False, dynamic (NTIdle request.client_name now),{IWorld|env & world = world})
				| otherwise
					= (mbData,done,dynamic (NTProcessingRequest request localState),{IWorld|env & world = world})
			Nothing
				= (["HTTP/1.1 400 Bad Request\r\n\r\n"], True, dynamic connState, env)

	eval (Just data) (connState :: NetTaskState) env  //(connState is either Idle or ReadingRequest)
		# rstate = case connState of
			(NTIdle client_name _)
				//Add new data to the request
				# request   = {newHTTPRequest & client_name = client_name, server_port = port}
				# (request, method_done, headers_done, data_done, error) = http_addRequestData request False False False data
				= {HttpReqState|request=request,method_done=method_done,headers_done=headers_done,data_done=data_done,error=error}
			(NTReadingRequest {HttpReqState|request, method_done, headers_done, data_done})
				//Add new data to the request
				# (request, method_done, headers_done, data_done, error) = http_addRequestData request method_done headers_done data_done (toString data)
				= {HttpReqState|request=request,method_done=method_done,headers_done=headers_done,data_done=data_done,error=error}
			_
				= {HttpReqState|request=newHTTPRequest,method_done=False,headers_done=False,data_done=False,error=True}
		| rstate.HttpReqState.error
			//Sent bad request response and disconnect
			= (["HTTP/1.1 400 Bad Request\r\n\r\n"], True, dynamic connState, env)
		| not rstate.HttpReqState.headers_done
			//Without headers we can't select our handler functions yet
			= ([], False, dynamic NTReadingRequest rstate, env)
		//Determine the handler
		= case selectHandler rstate.HttpReqState.request requestProcessHandlers of
			Nothing
				= (["HTTP/1.1 404 Not Found\r\n\r\n"], True, dynamic connState, env)
			Just (_,completeRequest,newReqHandler,procReqHandler,_)
				//Process a completed request, or as soon as the headers are done if the handler indicates so
				| rstate.HttpReqState.data_done || (not completeRequest)
					# request	= if completeRequest (http_parseArguments rstate.HttpReqState.request) rstate.HttpReqState.request
					//Determine if a  persistent connection was requested
					# keepalive	= isKeepAlive request
					// Create a response
					# (response,mbLocalState,env)	= newReqHandler request env
					//Add keep alive header if necessary
					# response	= if keepalive {response & rsp_headers = [("Connection","Keep-Alive"):response.rsp_headers]} response
					// Encode the response to the HTTP protocol format
					= case mbLocalState of
						Nothing	
							# reply		= encodeResponse True response
							| keepalive
                                # env=:{IWorld|world} = env
								# (now,world)       = time world
								= ([reply], False, dynamic (NTIdle rstate.HttpReqState.request.client_name now), {IWorld|env & world=world})
							| otherwise
								= ([reply], True, dynamic connState, env)
						Just localState	
							= ([(encodeResponse False response)], False, dynamic (NTProcessingRequest request localState), env)
				| otherwise
					= ([], False, (dynamic NTReadingRequest rstate), env)		

	//Close idle connections if the keepalive time has passed
	eval Nothing (connState=:(NTIdle ip (Timestamp t)) :: NetTaskState) iworld=:{IWorld|world}
		# (Timestamp now,world)	= time world//TODO: Do we really need to do this for every connection all the time?
		= ([], now >= t + keepAliveTime, dynamic connState, {IWorld|iworld & world = world})

	//Do nothing if no data arrives for now
	eval Nothing connState env = ([],False,connState,env)

    close connState env = (connState,env) //TODO Maybe we need to clean up

	//If we were processing a request and were interupted we need to
	//select the appropriate handler to wrap up
	handleConnectionLost (NTProcessingRequest request loc) env
		= case selectHandler request requestProcessHandlers of
			Nothing	= env
			Just (_,_,_,_,connLostHandler) = connLostHandler request loc env

	handleConnectionLost _ env = env

	selectHandler req [] = Nothing
	selectHandler req [h=:(pred,_,_,_,_):hs]
		| pred req.req_path	= Just h
							= selectHandler req hs

	isKeepAlive request = maybe (request.req_version == "HTTP/1.1") (\h -> (toLowerCase h == "keep-alive")) (get "Connection" request.req_headers)

    encodeResponse autoContentLength response=:{rsp_headers, rsp_data}
	    # rsp_headers = addDefault rsp_headers "Server" "iTasks HTTP Server"
	    # rsp_headers = addDefault rsp_headers "Content-Type" "text/html"
	    # rsp_headers = if autoContentLength
	    					(addDefault rsp_headers "Content-Length" (toString (size rsp_data)))
	    					rsp_headers
	    = toString {response & rsp_headers = rsp_headers}
    where		
    	addDefault headers hdr val = if ((lookup hdr headers) =: Nothing) [(hdr,val):headers] headers