implementation module iTasks.API.Extensions.Web
import iTasks
import Internet.HTTP, Text, Text.Encodings.MIME, Text.Encodings.UrlEncoding, StdArray, Data.Either

from iTasks._Framework.HttpUtil import http_addRequestData, http_parseArguments
import iTasks._Framework.HtmlUtil

import qualified Data.Map as DM
import qualified Data.List as DL

KEEPALIVE_TIME :== 5

:: HttpConnState
    = Idle String Timestamp
    | ReadingRequest HttpReqState
	| AwaitingResponse String Int Bool

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

derive class iTask HttpConnState, HttpReqState, HTTPRequest, HTTPResponse, HTTPMethod, HTTPProtocol, HTTPUpload, ConnectionType

serveWebService :: Int (HTTPRequest -> Task HTTPResponse) -> Task ()
serveWebService port handler 
	= withShared []
		\io ->
		manageConnections io -&&- handleRequests io
    @! ()
where
	manageConnections io
		= tcplisten port False (currentTimestamp |+< io) {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect}

    onConnect client_name (now,io)
		= (Ok (Idle client_name now), Nothing, [], False)

    whileConnected (Just data) l=:(Idle client_name last) (now,io)
		# request = {newHTTPRequest & client_name = client_name, server_port = port}
	 	# (request, method_done, headers_done, data_done, error) = http_addRequestData request False False False data
		# reqs = {HttpReqState|request=request,method_done=method_done,headers_done=headers_done,data_done=data_done,error=error}
		= whileReadingRequest data reqs now io
	whileConnected (Just data) l=:(ReadingRequest {HttpReqState|request, method_done, headers_done, data_done}) (now,io)
		# (request, method_done, headers_done, data_done, error) = http_addRequestData request method_done headers_done data_done (toString data)
		# reqs = {HttpReqState|request=request,method_done=method_done,headers_done=headers_done,data_done=data_done,error=error}
		= whileReadingRequest data reqs now io

	whileConnected Nothing l=:(AwaitingResponse client_name reqId keepalive) (now,io)
		= case getResponse reqId io of
			(Nothing,_) = (Ok l, Nothing, [], False)
			(Just response,io)
				//Add keep alive header if necessary
				# response	= if keepalive {response & rsp_headers = [("Connection","Keep-Alive"):response.rsp_headers]} response
				# reply		= encodeResponse True response
				= (Ok (Idle client_name now), Just io, [reply], keepalive)

	whileConnected Nothing l=:(Idle client_name (Timestamp last)) (Timestamp now,_) //Close idle connections if the keepalive time passed
		= (Ok l, Nothing, [], now - last > KEEPALIVE_TIME)

    whileConnected _ l (now,io)
		= (Ok l, Nothing, [], False)

	whileReadingRequest data reqs now io
		| reqs.HttpReqState.error
			//Sent bad request response and disconnect
			= (Ok (Idle reqs.HttpReqState.request.client_name now) , Nothing, ["HTTP/1.1 400 Bad Request\r\n\r\n"], True)
		| not reqs.HttpReqState.headers_done
			//Without headers we can't do anything yet
			= (Ok (ReadingRequest reqs), Nothing, [], False)
		| not reqs.HttpReqState.data_done	
			//For now only support full requests
			= (Ok (ReadingRequest reqs), Nothing, [], False)
		//Queue request to get a response
		# request	= http_parseArguments reqs.HttpReqState.request 
		//Determine if a  persistent connection was requested
		# keepalive	= isKeepAlive request
		//Add the request to be handled and wait
		# (reqId,io) = addRequest request io
		= (Ok (AwaitingResponse request.client_name reqId keepalive), Just io, [], False)

    onDisconnect l _        = (Ok l, Nothing)

	isKeepAlive request = maybe (request.req_version == "HTTP/1.1") (\h -> (toLowerCase h == "keep-alive")) ('DM'.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 (('DL'.lookup hdr headers) =: Nothing) [(hdr,val):headers] headers

	handleRequests io
		= 	forever (
				(watch io @ listRequests) 								 //Watch for unhandled requests
			>>* [OnValue (ifValue (not o isEmpty) (createResponses io))] //Handle the new requests and store responses
			)
	
	createResponses slist requests 
		= 	allTasks [handler req \\ (_,req) <- requests]
		>>- \responses ->
			upd (addResponses [(reqId,rsp) \\ (reqId,_) <- requests & rsp <- responses]) slist
		@! ()
	where
		addResponses [] list = list
		addResponses [(reqId,rsp):rest] list = addResponses rest (addResponse reqId rsp list)
		
//The data structure shared between the management of connections and the actual processing of requests
:: ConnectionList :== [(Int,Either HTTPRequest HTTPResponse)]
:: RequestId 	:== Int

addRequest :: HTTPRequest ConnectionList -> (RequestId,ConnectionList)
addRequest req list = addRequest` 0 req list
where
	addRequest` max req [] = let max` = max + 1 in (max`,[(max`,Left req)])
	addRequest` max req [x=:(i,_):xs] = let (id,xs`) = addRequest` (if (i > max) i max) req xs in (id,[x:xs`])

listRequests :: ConnectionList -> [(RequestId,HTTPRequest)]
listRequests list = [(i,req) \\ (i,Left req) <- list]

addResponse :: RequestId HTTPResponse ConnectionList -> ConnectionList
addResponse reqId rsp [] = []
addResponse reqId rsp [x=:(i,_):xs]
	| i == reqId 	= [(i,Right rsp):xs]
	| otherwise		= [x:addResponse reqId rsp xs]

getResponse :: RequestId ConnectionList -> (Maybe HTTPResponse,ConnectionList)
getResponse reqId [] = (Nothing,[])
getResponse reqId [x=:(i,Right rsp):xs]
	| i == reqId 	     = (Just rsp,xs)
	| otherwise  		 = let (mbrsp,xs`) = getResponse reqId xs in (mbrsp,[x:xs])
getResponse reqId [x:xs] = let (mbrsp,xs`) = getResponse reqId xs in (mbrsp,[x:xs])

serveFile :: [FilePath] HTTPRequest -> Task HTTPResponse
serveFile [] req = return (notFoundResponse req)
serveFile [d:ds] req=:{HTTPRequest|req_path}
	= 	try (importTextFile (d +++ filePath) @ toResponse)
		    (\(FileException _ _) -> serveFile ds req)
where
	//Translate a URL path to a filesystem path
	filePath = ((replaceSubString "/" {pathSeparator}) o (replaceSubString ".." "")) (urlDecode req_path)
	mimeType = extensionToMimeType (takeExtension filePath)

	toResponse content
	  = {HTTPResponse|okResponse
		& rsp_headers =
			[("Content-Type", mimeType)
			,("Content-Length", toString (size content))]
		, rsp_data = content
		}