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
161
162
163
164
165
166
167
168
169
|
(* 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;
;;
let serve fd =
let config = Nethttpd_kernel.default_http_protocol_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
;;
let conf_debug() =
(* Set the environment variable DEBUG to either:
- a list of Netlog module names
- the keyword "ALL" to output all messages
- the keyword "LIST" to output a list of modules
By setting DEBUG_WIN32 additional debugging for Win32 is enabled.
*)
let debug = try Sys.getenv "DEBUG" with Not_found -> "" in
if debug = "ALL" then
Netlog.Debug.enable_all()
else if debug = "LIST" then (
List.iter print_endline (Netlog.Debug.names());
exit 0
)
else (
let l = Netstring_str.split (Netstring_str.regexp "[ \t\r\n]+") debug in
List.iter
(fun m -> Netlog.Debug.enable_module m)
l
);
if (try ignore(Sys.getenv "DEBUG_WIN32"); true with Not_found -> false) then
Netsys_win32.Debug.debug_c_wrapper true
;;
Netsys_signal.init();
conf_debug();
start();;
|
