Commit c86b2a28 authored by Bas Lijnse's avatar Bas Lijnse

Added a debug option to the HTTP 1.0 Server


git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@152 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 3ac3f069
...@@ -39,6 +39,10 @@ http_emptyRequest :: HTTPRequest ...@@ -39,6 +39,10 @@ http_emptyRequest :: HTTPRequest
http_emptyResponse :: HTTPResponse http_emptyResponse :: HTTPResponse
http_emptyUpload :: HTTPUpload 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 //Lookup a value in a list of arguments or headers. When the argument or header is not found
//return the default value. //return the default value.
//Eg: foo = http_getValue "foo" arguments 0 //Eg: foo = http_getValue "foo" arguments 0
......
...@@ -30,6 +30,55 @@ http_emptyUpload = { upl_name = "" ...@@ -30,6 +30,55 @@ http_emptyUpload = { upl_name = ""
, upl_content = "" , 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 :: String [(String, String)] a -> a | fromString a
http_getValue name values def = hd ([fromString v \\ (n,v) <- values | n == name] ++ [def]) http_getValue name values def = hd ([fromString v \\ (n,v) <- values | n == name] ++ [def])
...@@ -11,6 +11,7 @@ import Http ...@@ -11,6 +11,7 @@ import Http
:: HTTPServerOption = HTTPServerOptPort Int // The port on which the server listens (default is 80) :: 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) | 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) | 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 // Start the HTTP server
// The first argument is a list of server options // The first argument is a list of server options
......
...@@ -8,7 +8,7 @@ import StdTCP ...@@ -8,7 +8,7 @@ import StdTCP
http_startServer :: [HTTPServerOption] [((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))] *World -> *World http_startServer :: [HTTPServerOption] [((String -> Bool),(HTTPRequest *World-> (HTTPResponse,*World)))] *World -> *World
http_startServer options handlers world http_startServer options handlers world
//Start the listener //Start the listener
# (listener,world) = startListener (getPortOption options) world # (listener,world) = startListener (getPortOption options) world
//Enter the endless loop //Enter the endless loop
= loop options handlers listener [] [] [] world = loop options handlers listener [] [] [] world
...@@ -36,6 +36,7 @@ loop options handlers listener rchannels schannels requests world ...@@ -36,6 +36,7 @@ loop options handlers listener rchannels schannels requests world
# ((TCP_Listeners [listener:_]) :^: (TCP_RChannels rchannels)) = glue # ((TCP_Listeners [listener:_]) :^: (TCP_RChannels rchannels)) = glue
//A new client attempts to connect //A new client attempts to connect
| who == 0 | who == 0
# world = debug "New connection opened" options world
# (tReport, mbNewMember, listener, world) = receive_MT (Just 0) listener world # (tReport, mbNewMember, listener, world) = receive_MT (Just 0) listener world
| tReport <> TR_Success = loop options handlers listener rchannels schannels requests world //Just continue | tReport <> TR_Success = loop options handlers listener rchannels schannels requests world //Just continue
# (ip,{sChannel,rChannel}) = fromJust mbNewMember # (ip,{sChannel,rChannel}) = fromJust mbNewMember
...@@ -69,14 +70,20 @@ loop options handlers listener rchannels schannels requests world ...@@ -69,14 +70,20 @@ loop options handlers listener rchannels schannels requests world
//Process a completed request //Process a completed request
| method_done && headers_done && data_done | method_done && headers_done && data_done
# request = if (getParseOption options) (http_parseArguments request) request # request = if (getParseOption options) (http_parseArguments request) request
# world = debug "Processing request:" options world
# world = debug request options world
// Create a response // Create a response
# (response,world) = http_makeResponse request handlers (getStaticOption options)world # (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 // Encode the response to the HTTP protocol format
# (reply, world) = http_encodeResponse response True world # (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 // Send the encoded response to the client
# (currentschannel,world) = send (toByteSeq reply) currentschannel world # (currentschannel,world) = send (toByteSeq reply) currentschannel world
# world = closeRChannel currentrchannel world
# world = closeChannel currentschannel world # world = closeChannel currentschannel world
# world = closeRChannel currentrchannel world
= loop options handlers listener rchannels schannels requests world = loop options handlers listener rchannels schannels requests world
//We do not have everything we need yet, so continue //We do not have everything we need yet, so continue
...@@ -104,9 +111,17 @@ getStaticOption [x:xs] = case x of (HTTPServerOptStaticFallback b) = b ...@@ -104,9 +111,17 @@ getStaticOption [x:xs] = case x of (HTTPServerOptStaticFallback b) = b
getParseOption :: [HTTPServerOption] -> Bool getParseOption :: [HTTPServerOption] -> Bool
getParseOption [] = True getParseOption [] = True
getParseOption [x:xs] = case x of (HTTPServerOptParseArguments b) = b getParseOption [x:xs] = case x of (HTTPServerOptParseArguments b) = b
_ = getParseOption xs _ = getParseOption xs
getDebugOption :: [HTTPServerOption] -> Bool
getDebugOption [] = False
getDebugOption [x:xs] = case x of (HTTPServerOptDebug b) = b
\ No newline at end of file _ = 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
...@@ -199,7 +199,9 @@ http_encodeResponse {rsp_headers = headers, rsp_data = data} withreply world //W ...@@ -199,7 +199,9 @@ http_encodeResponse {rsp_headers = headers, rsp_data = data} withreply world //W
# (time,world) = getCurrentTime world # (time,world) = getCurrentTime world
# reply = if withreply # reply = if withreply
("HTTP/1.0 " +++ (http_getValue "Status" headers "200 OK") +++ "\r\n") ("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-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 +++ ("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 +++ ("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 ...@@ -208,7 +210,7 @@ http_encodeResponse {rsp_headers = headers, rsp_data = data} withreply world //W
= (reply, world) = (reply, world)
where where
//Do not add these headers two times //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 //Format the current date/time
now date time = (weekday date.dayNr) +++ ", " +++ (toString date.day) +++ " " +++ (month date.month) +++ " " +++ (toString date.year) +++ " " now date time = (weekday date.dayNr) +++ ", " +++ (toString date.day) +++ " " +++ (month date.month) +++ " " +++ (toString date.year) +++ " "
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment