implementation module HttpUtil

import HTTP
import StdArray, StdOverloaded, StdString, StdFile, StdBool, StdInt, StdArray, StdList, StdFunc, StdTuple
import Time, Text, UrlEncoding, Map

mkString	:: ![Char] -> *String
mkString	listofchar				= {c \\ c <- listofchar }

mkList		:: !String -> [Char]
mkList		string					= [c \\ c <-: string ]

http_splitMultiPart :: !String !String -> [([(String,String)], String)]
http_splitMultiPart boundary body
	# startindex		= indexOf ("--" +++ boundary +++ "\r\n") body //Locate the first boundary
	| startindex == -1	= [] //Fail
	# endindex			= indexOf ("\r\n" +++ "--" +++ boundary +++ "--") body //Locate the final boundary
	| endindex == -1	= [] //Fail
	# body				= body % (startindex + (size boundary) + 4, endindex - 1)
	# parts				= split ("\r\n" +++ "--" +++ boundary +++ "\r\n") body
	= map parsePart parts
where
	parsePart :: String -> ([(String,String)], String)
	parsePart part 
		# index 		= indexOf "\r\n\r\n" part
		| index < 1 	= ([], part)
						= ([header \\ (header,error) <- map http_parseHeader (split "\r\n" (part % (0, index - 1))) | not error]
							, part % (index + 4, size part))

//Parsing of HTTP Request messages

//Add new data to a request
http_addRequestData :: !HTTPRequest !Bool !Bool !Bool !String -> (HTTPRequest, Bool, Bool, Bool, Bool)
http_addRequestData req requestline_done headers_done data_done data
	# req	= {req & req_data = req.req_data +++ data}	//Add the new data
	//Parsing of the request line
	| not requestline_done
		# index = indexOf "\r\n" req.req_data
		| index == -1	= (req,False,False,False,False)	//The first line is not complete yet
		| otherwise
			# (method,path,query,version,error) = http_parseRequestLine (req.req_data % (0, index - 1))
			| error	= (req,False,False,False,True)			//We failed to parse the request line
			# req = {req & req_method = method, req_path = path, req_query = query, req_version = version, req_data = req.req_data % (index + 2, size req.req_data) }
			= http_addRequestData req True False False ""	//We are done with the request line but still need to inspect the rest of the data
	//Parsing of headers
	| not headers_done
		# index = indexOf "\r\n" req.req_data
		| index == -1	= (req,True,False,False,False)		//We do not have a full line yet
		| index == 0										//We have an empty line, this means we have received all the headers
			# req = {req & req_data = req.req_data % (2, size req.req_data)}
			= http_addRequestData req True True False ""	//Headers are finished, continue with the data part
		| otherwise
			# (header,error) = http_parseHeader (req.req_data % (0, index - 1))
			| error = (req,True,False,False,True)			//We failed to parse the header
			# req = {req & req_headers = put (fst header) (snd header) req.req_headers, req_data = req.req_data % (index + 2, size req.req_data)}
			= http_addRequestData req True False False ""	//We continue to look for more headers
	//Addition of data
	| not data_done
		# datalength	= toInt (http_getValue "Content-Length" req.req_headers "0")
		| (size req.req_data) < datalength	= (req,True,True,False,False)	//We still need more data
											= (req,True,True,True,False)	//We have all data and are done
	//Data is added while we were already done
	= (req,True,True,True,False) 


http_getValue :: !String !(Map String String) !String -> String
http_getValue key valuemap defaultval
	= fromMaybe defaultval (get key valuemap)

http_parseRequestLine :: !String -> (!String,!String,!String,!String,!Bool)
http_parseRequestLine line
	# parts	= split " " line
	| length parts <> 3	= ("","","","",True)
	# [method,path,version:_]	= parts
	# qindex					= indexOf "?" path
	| qindex <> -1				= (method, path % (0, qindex - 1), path % (qindex + 1, size path), version, False)
								= (method, path, "", version, False)
								
http_parseHeader :: !String -> (!(String,String), !Bool)
http_parseHeader header
	# index					= indexOf ":" header
	| index < 1				= (("",""), False)
	# name					= trim (header % (0, index - 1))
	# value					= trim (header % (index + 1, size header))
	= ((name,value), False)

http_parseArguments :: !HTTPRequest -> HTTPRequest
http_parseArguments req
	# req 							= {req & arg_get = http_parseGetArguments req}		//Parse get arguments
	| isPost req.req_headers		= {req & arg_post = http_parsePostArguments req}	//Parse post arguments
	| isMultiPart req.req_headers
		# (post,uploads)			= http_parseMultiPartPostArguments req
		= {req & arg_post = post, arg_uploads = uploads}								//Parse post arguments + uploads
	| otherwise						= req
where
	isPost headers = (http_getValue "Content-Type" headers "") % (0,32) == "application/x-www-form-urlencoded"
	isMultiPart headers = (http_getValue "Content-Type" headers "") % (0,18) == "multipart/form-data"
	
http_parseGetArguments :: !HTTPRequest -> Map String String
http_parseGetArguments req
	| req.req_query == ""	= fromList []
							= fromList (http_parseUrlEncodedArguments req.req_query)

http_parsePostArguments :: !HTTPRequest -> Map String String
http_parsePostArguments req	= fromList (http_parseUrlEncodedArguments req.req_data)

http_parseUrlEncodedArguments :: !String -> [(String,String)]
http_parseUrlEncodedArguments s = [(urlDecode name, urlDecode (join "=" value)) \\ [name:value] <- map (split "=") (split "&" s)]

http_parseMultiPartPostArguments :: !HTTPRequest -> (Map String String, Map String HTTPUpload)
http_parseMultiPartPostArguments req
	# mimetype		= http_getValue "Content-Type" req.req_headers ""
	# index			= indexOf "boundary=" mimetype
	| index == -1	= (newMap,newMap)
	# boundary		= mimetype % (index + 9, size mimetype)
	# parts			= http_splitMultiPart boundary req.req_data
	= parseParts parts newMap newMap
where
	parseParts [] arguments uploads	= (arguments, uploads)
	parseParts [(headers, body):xs] arguments uploads
		# disposition		= http_getValue "Content-Disposition" (fromList headers) ""
		| disposition == ""	= parseParts xs arguments uploads
		# name				= getParam "name" disposition
		| name == ""		= parseParts xs arguments uploads
		# filename			= getParam "filename" disposition
		| filename == ""	= parseParts xs (put name body arguments) uploads
		| otherwise			= parseParts xs arguments (put name { newHTTPUpload
														& upl_name		= name
														, upl_filename	= filename
														, upl_mimetype	= http_getValue "Content-Type" (fromList headers) ""
														, upl_content	= body
														} uploads)
	getParam name header
		# index	= indexOf (name +++ "=") header
		| index == -1	= ""
		# header = header % (index + (size name) + 1, size header)
		# index	= indexOf ";" header
		| index == -1	= removequotes header
						= removequotes (header % (0, index - 1))

	removequotes s
		| size s < 2	= s
		# start	= if (s.[0] == '"') 1 0
		# end = if (s.[size s - 1] == '"') (size s - 2) (size s - 1)
		= s % (start, end) 

//Construction of HTTP Response messages
http_makeResponse :: !HTTPRequest ![((String -> Bool),(HTTPRequest *World -> (HTTPResponse, *World)))] !Bool !*World -> (!HTTPResponse,!*World)
http_makeResponse request [] fallback world 										//None of the request handlers matched
	= if fallback
		(http_staticResponse request world)											//Use the static response handler
		(http_notfoundResponse request world)										//Raise an error
http_makeResponse request [(pred,handler):rest] fallback world
	| (pred request.req_path)		= handler request world							//Apply handler function
									= http_makeResponse request rest fallback world	//Search the rest of the list


http_encodeResponse :: !HTTPResponse !Bool !*World -> (!String, !*World)
http_encodeResponse {rsp_headers = headers, rsp_data = data} withreply world //When used directly the 'Status' header should be converted to 
	# (tm,world) = gmTime world
	# reply = if withreply
			("HTTP/1.0 " +++ (http_getValue "Status" headers "200 OK") +++ "\r\n")
			("Status: " +++ (http_getValue "Status" headers "200 OK") +++ "\r\n")
	# reply = reply +++ ("Date: " +++ (http_getValue "Date" headers (now tm)) +++ "\r\n")										//Date
	# reply = reply +++ ("Server: " +++ (http_getValue "Server" headers "Clean HTTP 1.0 Server") +++ "\r\n")					//Server identifier	
	# reply = reply +++	("Content-Type: " +++ (http_getValue "Content-Type" headers "text/html") +++ "\r\n")					//Content type header
	# reply = reply +++	("Content-Length: " +++ (toString (size data)) +++ "\r\n")												//Content length header
	# reply = reply +++ ("Last-Modified: " +++ (http_getValue "Last-Modified" headers (now tm)) +++ "\r\n")						//Timestamp for caching
	# reply = reply +++	(foldr (+++) "" [(n +++ ": " +++ v +++ "\r\n") \\ (n,v) <- toList headers | not (skipHeader n)])				//Additional headers
	# reply = reply +++	("\r\n" +++ data)																						//Separator + data
	= (reply, world)
where
	//Do not add these headers two times
	skipHeader s = isMember s ["Status","Date","Server","Content-Type","Content-Length","Last-Modified"]

	//Format the current date/time
	now tm				=	(weekday tm.wday) +++ ", " +++ (toString tm.mday) +++ " " +++ (month tm.mon) +++ " " +++ (toString (tm.year + 1900)) +++ " "
								+++	(toString tm.hour) +++ ":" +++ (toString tm.min) +++ ":" +++ (toString tm.sec) +++ " GMT"
								
	weekday 0					= "Sun"
	weekday 1					= "Mon"
	weekday 2					= "Tue"
	weekday 3					= "Wed"
	weekday 4					= "Thu"
	weekday 5					= "Fri"
	weekday 6					= "Sat"
	
	month	0					= "Jan"
	month	1					= "Feb"
	month	2					= "Mar"
	month	3					= "Apr"
	month	4					= "May"
	month	5					= "Jun"
	month	6					= "Jul"
	month	7					= "Aug"
	month	8					= "Sep"
	month   9					= "Oct"
	month  10					= "Nov"
	month  11					= "Dec"
	

//Error responses
http_notfoundResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_notfoundResponse req world = ({rsp_headers = put "Status" "404 Not Found" newMap, rsp_data = "404 - Not found"}, world)

http_forbiddenResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_forbiddenResponse req world = ({rsp_headers = put "Status" "403 Forbidden" newMap, rsp_data = "403 - Forbidden"}, world)

//Static content
http_staticResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_staticResponse req world
	# filename				= req.req_path % (1, size req.req_path)		//Remove first slash
	# (type, world)			= http_staticFileMimeType filename world
	# (ok, content, world)	= http_staticFileContent filename world
	| not ok 				= http_notfoundResponse req world
							= ({rsp_headers = fromList [("Status","200 OK"),
											   			("Content-Type", type),
											   			("Content-Length", toString (size content))]
							   ,rsp_data = content}, world)						
							
http_staticFileContent :: !String !*World -> (!Bool, !String, !*World)
http_staticFileContent filename world
	# (ok, file, world)	= fopen filename FReadData world
	| not ok			= (False, "Could not open file", world)
	# (ok, file)		= fseek file 0 FSeekEnd
	| not ok			= (False, "Seek to end of file does not succeed", world)
	# (pos, file)		= fposition file
	# (ok, file)		= fseek file (~pos) FSeekCur
	| not ok			= (False, "Seek to begin of file does not succeed", world)
	# (content, file)	= freads file pos
	# (ok, world)		= fclose file world
	= (True, content, world)

http_staticFileMimeType :: !String !*World -> (!String, !*World)
http_staticFileMimeType ".jpg" world = ("image/jpeg",world)
http_staticFileMimeType ".png" world = ("image/png",world)
http_staticFileMimeType ".gif" world = ("image/gif",world)
http_staticFileMimeType ".bmp" world = ("image/bmp",world)

http_staticFileMimeType ".htm" world = ("text/html",world)
http_staticFileMimeType ".html" world = ("text/html",world)
http_staticFileMimeType ".txt" world = ("text/plain",world)
http_staticFileMimeType ".css" world = ("text/css",world)
http_staticFileMimeType ".js" world = ("text/javascript",world)
http_staticFileMimeType "" world = ("application/octet-stream",world)
http_staticFileMimeType name world = http_staticFileMimeType (name % (1, size name)) world

http_serverControl :: !HTTPResponse -> String
http_serverControl response
	= case (get "X-Server-Control" response.rsp_headers) of
		Just control	= control
		_				= ""