HttpUtil.icl 12.8 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
implementation module HttpUtil

import Http, HttpTextUtil
import StdArray, StdOverloaded, StdString, StdFile, StdBool, StdInt, StdArray, StdList
import StdTime

//General utility functions
http_urlencode :: !String -> String
http_urlencode s = mkString (urlEncode` (mkList s))
where
	urlEncode` :: ![Char] -> [Char]
	urlEncode` []						= []
	urlEncode` [x:xs] 
	| isAlphanum x						= [x  : urlEncode` xs]
	| otherwise							= urlEncodeChar x ++ urlEncode` xs
	where
		urlEncodeChar x 
		# (c1,c2)						= charToHex x
		= ['%', c1 ,c2]
	
		charToHex :: !Char -> (!Char, !Char)
		charToHex c						= (toChar (digitToHex (i >> 4)), toChar (digitToHex (i bitand 15)))
		where
		        i						= toInt c
		        digitToHex :: !Int -> Int
		        digitToHex d
		                | d <= 9		= d + toInt '0'
		                | otherwise		= d + toInt 'A' - 10

http_urldecode :: !String -> String
http_urldecode s						= mkString (urlDecode` (mkList s))
where
	urlDecode` :: ![Char] -> [Char]
	urlDecode` []						= []
	urlDecode` ['%',hex1,hex2:xs]		= [hexToChar(hex1, hex2):urlDecode` xs]
	where
		hexToChar :: !(!Char, !Char) -> Char
		hexToChar (a, b)				= toChar (hexToDigit (toInt a) << 4 + hexToDigit (toInt b))
		where
		        hexToDigit :: !Int -> Int
		        hexToDigit i
		                | i<=toInt '9'	= i - toInt '0'
43
		                | otherwise		= 10 + (i - toInt 'A')
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
	urlDecode` ['+':xs]				 	= [' ':urlDecode` xs]
	urlDecode` [x:xs]				 	= [x:urlDecode` xs]

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

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



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

//Parsing of HTTP Request messages
Bas Lijnse's avatar
Bas Lijnse committed
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107

//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 = text_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 = text_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 = [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) 


108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
http_parseRequestLine :: !String -> (!String,!String,!String,!String,!Bool)
http_parseRequestLine line
	# parts	= text_split " " line
	| length parts <> 3	= ("","","","",True)
	# [method,path,version:_]	= parts
	# qindex					= text_indexOf "?" path
	| qindex <> -1				= (method, path % (0, qindex - 1), path % (qindex + 1, size path), version, False)
								= (method, path, "", version, False)
								
http_parseHeader :: !String -> (!HTTPHeader, !Bool)
http_parseHeader header
	# index					= text_indexOf ":" header
	| index < 1				= (("",""), False)
	# name					= text_trim (header % (0, index - 1))
	# value					= text_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 "") == "application/x-www-form-urlencoded"
	isMultiPart headers = (http_getValue "Content-Type" headers "") % (0,18) == "multipart/form-data"
	
http_parseGetArguments :: !HTTPRequest -> [HTTPArgument]
http_parseGetArguments req
	| req.req_query == ""	= []
							= http_parseUrlEncodedArguments req.req_query

http_parsePostArguments :: !HTTPRequest -> [HTTPArgument]
http_parsePostArguments req	= http_parseUrlEncodedArguments req.req_data

http_parseUrlEncodedArguments :: !String -> [HTTPArgument]
http_parseUrlEncodedArguments s = [(http_urldecode name, http_urldecode (text_join "=" value)) \\ [name:value] <- map (text_split "=") (text_split "&" s)]

http_parseMultiPartPostArguments :: !HTTPRequest -> ([HTTPArgument],[HTTPUpload])
http_parseMultiPartPostArguments req
	# mimetype		= http_getValue "Content-Type" req.req_headers ""
	# index			= text_indexOf "boundary=" mimetype
	| index == -1	= ([],[])
	# boundary		= mimetype % (index + 9, size mimetype)
Bas Lijnse's avatar
Bas Lijnse committed
154
	# parts			= http_splitMultiPart boundary req.req_data
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
	= parseParts parts [] []
where
	parseParts [] arguments uploads	= (arguments, uploads)
	parseParts [(headers, body):xs] arguments uploads
		# disposition		= http_getValue "Content-Disposition" headers ""
		| disposition == ""	= parseParts xs arguments uploads
		# name				= getParam "name" disposition
		| name == ""		= parseParts xs arguments uploads
		# filename			= getParam "filename" disposition
		| filename == ""	= parseParts xs [(name,body):arguments] uploads
		| otherwise			= parseParts xs arguments [	{ http_emptyUpload
														& upl_name		= name
														, upl_filename	= filename
														, upl_mimetype	= http_getValue "Content-Type" headers ""
														, upl_content	= body
														}:uploads]
	getParam name header
		# index	= text_indexOf (name +++ "=") header
		| index == -1	= ""
		# header = header % (index + (size name) + 1, size header)
		# index	= text_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
186
187
188
189
190
191
192
193
194
195
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


196
197
198
199
200
201
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 
	# (date,world)	= getCurrentDate world
	# (time,world)	= getCurrentTime world
	# reply = if withreply
			("HTTP/1.0 " +++ (http_getValue "Status" headers "200 OK") +++ "\r\n")
202
203
204
			("Status: " +++ (http_getValue "Status" headers "200 OK") +++ "\r\n")
	# reply = reply +++ ("Date: " +++ (http_getValue "Date" headers (now date time)) +++ "\r\n")								//Date
	# reply = reply +++ ("Server: " +++ (http_getValue "Server" headers "Clean HTTP 1.0 Server") +++ "\r\n")					//Server identifier	
205
206
207
208
209
210
211
212
	# 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 date time)) +++ "\r\n")				//Timestamp for caching
	# reply = reply +++	(foldr (+++) "" [(n +++ ": " +++ v +++ "\r\n") \\ (n,v) <- headers | not (skipHeader n)])				//Additional headers
	# reply = reply +++	("\r\n" +++ data)																						//Separator + data
	= (reply, world)
where
	//Do not add these headers two times
213
	skipHeader s = isMember s ["Status","Date","Server","Content-Type","Content-Lenght","Last-Modified"]
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285

	//Format the current date/time
	now date time				=	(weekday date.dayNr) +++ ", " +++ (toString date.day) +++ " " +++ (month date.month) +++ " " +++ (toString date.year) +++ " "
								+++	(toString time.hours) +++ ":" +++ (toString time.minutes) +++ ":" +++ (toString time.seconds) +++ " GMT"
								
	weekday 1					= "Sun"
	weekday 2					= "Mon"
	weekday 3					= "Tue"
	weekday 4					= "Wed"
	weekday 5					= "Thu"
	weekday 6					= "Fri"
	weekday 7					= "Sat"
	
	month	1					= "Jan"
	month	2					= "Feb"
	month	3					= "Mar"
	month	4					= "Apr"
	month	5					= "May"
	month	6					= "Jun"
	month	7					= "Jul"
	month	8					= "Aug"
	month	9					= "Sep"
	month  10					= "Oct"
	month  11					= "Nov"
	month  12					= "Dec"
	

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

http_forbiddenResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
http_forbiddenResponse req world = ({rsp_headers = [("Status","403 Forbidden")], 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 = [("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