Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
clean-and-itasks
clean-libraries
Commits
17ba5e58
Commit
17ba5e58
authored
Apr 23, 2008
by
Bas Lijnse
Browse files
Added a debug option to the HTTP 1.0 Server
parent
416af90e
Changes
5
Hide whitespace changes
Inline
Side-by-side
libraries/Http/Http.dcl
View file @
17ba5e58
...
...
@@ -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
View file @
17ba5e58
...
...
@@ -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
View file @
17ba5e58
...
...
@@ -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
View file @
17ba5e58
...
...
@@ -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
View file @
17ba5e58
...
...
@@ -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
)
+++
" "
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment