Added a debug option to the HTTP 1.0 Server

libraries/Http/Http.dcl

@@ -39,6 +39,10 @@ http_emptyRequest	:: HTTPRequest
 http_emptyResponse	:: HTTPResponse
 http_emptyUpload	:: HTTPUpload
 
+//String instances
+instance toString HTTPRequest
+instance toString HTTPResponse
+
 //Lookup a value in a list of arguments or headers. When the argument or header is not found
 //return the default value.
 //Eg: foo = http_getValue "foo" arguments 0 

libraries/Http/Http.icl

@@ -30,6 +30,55 @@ http_emptyUpload	= {	upl_name		= ""
 					,	upl_content		= ""
 					}
 
+instance toString HTTPRequest
+where
+	toString {	req_method
+			 ,	req_path
+	 		 ,	req_query
+			 ,	req_version
+			 ,	req_protocol
+			 ,	req_headers	
+			 ,	req_data		
+			 ,	arg_get
+			 ,	arg_post
+			 ,	arg_uploads	
+			 ,	server_name
+			 ,	server_port
+			 ,	client_name
+			 }
+			 = "Method: " +++ req_method +++ "\n" +++
+			   "Path: " +++ req_path +++ "\n" +++
+			   "Query: " +++ req_query +++ "\n" +++
+			   "Version: " +++ req_version +++ "\n" +++
+			   "Protocol: " +++  toString req_protocol +++ "\n" +++
+			   "---Begin headers---\n" +++
+			   (foldr (+++) "" [ n +++ ": " +++ v +++ "\n" \\ (n,v) <- req_headers]) +++
+			   "---End headers---\n" +++
+			   "---Begin data---\n" +++
+			   req_data +++
+			   "--- End data---\n"
+			   
+instance toString HTTPResponse
+where
+	toString {	rsp_headers
+			 ,	rsp_data
+			 }
+			 = "---Begin headers---\n" +++
+			   (foldr (+++) "" [ n +++ ": " +++ v +++ "\n" \\ (n,v) <- rsp_headers]) +++
+			   "---End headers---\n" +++
+			   "---Begin data---\n" +++
+			   rsp_data +++
+			   "--- End data---\n"
+
+	
+instance toString HTTPProtocol
+where
+	toString HTTPProtoHTTP = "Http"
+	toString HTTPProtoHTTPS = "Https"
+		   
+
+
+
 http_getValue :: String [(String, String)] a -> a | fromString a
 http_getValue name values def = hd ([fromString v \\ (n,v) <- values | n == name] ++ [def])
 

libraries/Http/HttpServer.dcl

@@ -11,6 +11,7 @@ import Http
 :: HTTPServerOption	= HTTPServerOptPort Int				// The port on which the server listens (default is 80)
 					| HTTPServerOptStaticFallback Bool	// If all request handlers fail, should the static file handler be tried (default False)
 					| HTTPServerOptParseArguments Bool	// Should the query and body of the request be parsed (default True)
+					| HTTPServerOptDebug Bool			// Should the server write debug info to the stdout
 					
 // Start the HTTP server
 // The first argument is a list of server options

libraries/Http/HttpServer.icl

@@ -8,7 +8,7 @@ import StdTCP
 http_startServer :: [HTTPServerOption] [((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))] *World -> *World
 http_startServer options handlers world
 	//Start the listener
-	# (listener,world) = startListener (getPortOption options) world
+	# (listener,world)	= startListener (getPortOption options) world
 	//Enter the endless loop
 	= loop options handlers listener [] [] [] world
 
@@ -36,6 +36,7 @@ loop options handlers listener rchannels schannels requests world
 	# ((TCP_Listeners [listener:_]) :^: (TCP_RChannels rchannels)) = glue
 	//A new client attempts to connect
 	| who == 0
+		# world										= debug "New connection opened" options world
 		# (tReport, mbNewMember, listener, world)	= receive_MT (Just 0) listener world
 		| tReport <> TR_Success						= loop options handlers listener rchannels schannels requests world //Just continue
 		# (ip,{sChannel,rChannel})					= fromJust mbNewMember
@@ -69,14 +70,20 @@ loop options handlers listener rchannels schannels requests world
 			//Process a completed request
 			| method_done && headers_done && data_done
 				#  request			= if (getParseOption options) (http_parseArguments request) request
+				# world				= debug "Processing request:" options world
+				# world				= debug request	options world
 				// Create a response
 				# (response,world)	= http_makeResponse request handlers (getStaticOption options)world
+				# world				= debug "Generated response:" options world
+				# world				= debug response options world
 				// Encode the response to the HTTP protocol format
 				# (reply, world) = http_encodeResponse response True world
+				# world				= debug "Sending encoded reply:" options world
+				# world				= debug reply options world
 				// Send the encoded response to the client
 				# (currentschannel,world) = send (toByteSeq reply) currentschannel world
-				# world = closeRChannel currentrchannel world
 				# world = closeChannel currentschannel world
+				# world = closeRChannel currentrchannel world				
 				= loop options handlers listener rchannels schannels requests world		
 		
 			//We do not have everything we need yet, so continue
@@ -104,9 +111,17 @@ getStaticOption [x:xs] = case x of (HTTPServerOptStaticFallback b) = b
 
 getParseOption :: [HTTPServerOption] -> Bool
 getParseOption [] = True
-getParseOption [x:xs] = case x of (HTTPServerOptParseArguments b)	= b
+getParseOption [x:xs] = case x of (HTTPServerOptParseArguments b)	= b						
 								  _									= getParseOption xs
 
-
-
-	
\ No newline at end of file
+getDebugOption :: [HTTPServerOption] -> Bool
+getDebugOption [] = False
+getDebugOption [x:xs] = case x of (HTTPServerOptDebug b)	= b
+								  _							= getDebugOption xs
+								  
+debug:: a [HTTPServerOption] *World -> *World | toString a
+debug msg options world
+	| not (getDebugOption options)	= world
+	# (sio, world)					= stdio world
+	# sio							= fwrites ((toString msg) +++ "\n") sio
+	= snd (fclose sio world)
\ No newline at end of file

libraries/Http/HttpUtil.icl

@@ -199,7 +199,9 @@ http_encodeResponse {rsp_headers = headers, rsp_data = data} withreply world //W
 	# (time,world)	= getCurrentTime world
 	# reply = if withreply
 			("HTTP/1.0 " +++ (http_getValue "Status" headers "200 OK") +++ "\r\n")
-			("Status: " +++ (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 date time)) +++ "\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 date time)) +++ "\r\n")				//Timestamp for caching
@@ -208,7 +210,7 @@ http_encodeResponse {rsp_headers = headers, rsp_data = data} withreply world //W
 	= (reply, world)
 where
 	//Do not add these headers two times
-	skipHeader s = isMember s ["Status","Content-Type","Content-Lenght","Last-Modified"]
+	skipHeader s = isMember s ["Status","Date","Server","Content-Type","Content-Lenght","Last-Modified"]
 
 	//Format the current date/time
 	now date time				=	(weekday date.dayNr) +++ ", " +++ (toString date.day) +++ " " +++ (month date.month) +++ " " +++ (toString date.year) +++ " "