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
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
......
......@@ -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])
......@@ -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
......
......@@ -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
......@@ -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) +++ " "
......
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