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
43
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
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
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
154
155
156
157
158
159
160
|
(* A test daemon, only using the kernel *)
open Printf
let generate resp =
printf "Generating response\n"; flush stdout;
let h =
new Netmime.basic_mime_header
[ "Content-type", "text/html" ] in
let data =
"<html>\n" ^
" <head><title>Easy Daemon</title></head>\n" ^
" <body>\n" ^
" <a href='foo'>GET something</a><br>\n" ^
" <form method=POST encoding='form-data'>\n" ^
" <input type=hidden name=sample value='sample'>\n" ^
" <input type=submit value='POST something'>\n" ^
" </form>\n" ^
" </body>\n" ^
"</html>" in
resp # send (`Resp_status_line (200, "OK"));
resp # send (`Resp_header h);
resp # send (`Resp_body (data, 0, String.length data));
resp # send `Resp_end
;;
let generate_error resp =
printf "Generating error response\n"; flush stdout;
let h =
new Netmime.basic_mime_header
[ "Content-type", "text/html" ] in
let data =
"<html>\n" ^
" <head><title>Bad Request from Easy Daemon</title></head>\n" ^
" <body>\n" ^
" Bad Request!\n" ^
" </body>\n" ^
"</html>" in
resp # send (`Resp_status_line (400, "Bad Request"));
resp # send (`Resp_header h);
resp # send (`Resp_body (data, 0, String.length data));
resp # send `Resp_end;
;;
class config
?(max_reqline_length = 256)
?(max_header_length = 32768)
?(max_trailer_length = 32768)
?(limit_pipeline_length = 5)
?(limit_pipeline_size = max_int)
() : Nethttpd_kernel.http_protocol_config =
object
method config_max_reqline_length = max_reqline_length
method config_max_header_length = max_header_length
method config_max_trailer_length = max_trailer_length
method config_limit_pipeline_length = limit_pipeline_length
method config_limit_pipeline_size = limit_pipeline_size
method config_announce_server = `Ocamlnet
end
;;
let serve fd =
let config = new config() in
let proto = new Nethttpd_kernel.http_protocol config fd in
let rec next_token () =
if proto # recv_queue_len = 0 then (
proto # cycle ~block:(-1.0) (); (* block forever *)
next_token()
)
else
proto # receive()
in
let cur_tok = ref ( next_token() ) in
let cur_resp = ref None in
while !cur_tok <> `Eof do
( match !cur_tok with
| `Req_header (((meth, uri), v), hdr, resp) ->
printf "Request: method = %s, uri = %s\n" meth uri;
flush stdout;
cur_resp := Some resp
| `Req_expect_100_continue ->
( match !cur_resp with
| Some resp -> resp # send Nethttpd_kernel.resp_100_continue
| None -> assert false
)
| `Req_end ->
printf "Pipeline length: %d\n" proto#pipeline_len;
( match !cur_resp with
| Some resp -> generate resp
| None -> assert false
);
cur_resp := None
| `Fatal_error e ->
let name = Nethttpd_kernel.string_of_fatal_error e in
printf "Fatal_error: %s\n" name;
flush stdout;
| `Bad_request_error (e, resp) ->
let name = Nethttpd_kernel.string_of_bad_request_error e in
printf "Bad_request_error: %s\n" name;
flush stdout;
generate_error resp
| `Timeout ->
printf "Timeout\n";
flush stdout;
| _ ->
()
);
cur_tok := next_token()
done;
(* Send the remaining responses:*)
while proto # resp_queue_len > 0 do
proto # cycle ~block:(-1.0) ();
done;
proto # shutdown();
if proto # need_linger then (
printf "Lingering close!\n";
flush stdout;
let lc = new Nethttpd_kernel.lingering_close fd in
while lc # lingering do
lc # cycle ~block:true ()
done
)
else
Unix.close fd
;;
let start() =
let master_sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Unix.setsockopt master_sock Unix.SO_REUSEADDR true;
Unix.bind master_sock (Unix.ADDR_INET(Unix.inet_addr_any, 8765));
Unix.listen master_sock 100;
printf "Listening on port 8765\n";
flush stdout;
while true do
try
let conn_sock, _ = Unix.accept master_sock in
Unix.set_nonblock conn_sock;
serve conn_sock
with
Unix.Unix_error(Unix.EINTR,_,_) -> () (* ignore *)
done
;;
Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
start();;
|
