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
|
(* Simple example for event-based engines *)
open Printf
let generate (cgi : Netcgi.cgi_activation) =
(* A Netcgi-based content provider *)
cgi # set_header
~cache:`No_cache
~content_type:"text/html; charset=\"iso-8859-1\""
();
let data =
"<html>\n" ^
" <head><title>Easy Engine</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
cgi # output # output_string data;
cgi # output # commit_work();
;;
let on_request notification =
(* This function is called when the full HTTP request has been received. For
* simplicity, we create a [std_activation] to serve the request.
*
* An advanced implementation could set up further notifications to get informed
* whenever there is space in the response buffer for additional output.
* Currently, data is fully buffered (first
* in the transactional buffer, then in the response buffer), and only when
* the message is complete, the transmission to the client starts.
* By generating only the next part of the response when there is space in
* the response buffer, the advanced implementation can prevent that the
* buffers become large.
*)
printf "Received HTTP request\n";
flush stdout;
( try
let env = notification # environment in
let cgi =
Netcgi_common.cgi_with_args
(new Netcgi_common.cgi)
(env :> Netcgi.cgi_environment)
Netcgi.buffered_transactional_outtype
env#input_channel
(fun _ _ _ -> `Automatic) in
generate cgi;
with
e ->
printf "Uncaught exception: %s\n" (Printexc.to_string e);
flush stdout
);
notification # schedule_finish()
;;
let on_request_header (notification : Nethttpd_engine.http_request_header_notification) =
(* After receiving the HTTP header: We always decide to accept the HTTP body, if any
* is following. We do not set up special processing of this body, it is just
* buffered until complete. Then [on_request] will be called.
*
* An advanced server could set up a further notification for the HTTP body. This
* additional function would be called whenever new body data arrives. (Do so by
* calling [notification # environment # input_ch_async # request_notification].)
*)
printf "Received HTTP header\n";
flush stdout;
notification # schedule_accept_body ~on_request ()
;;
let serve_connection ues fd =
(* Creates the http engine for the connection [fd]. When a HTTP header is received
* the function [on_request_header] is called.
*)
printf "Connected\n";
flush stdout;
let config = Nethttpd_engine.default_http_engine_config in
Unix.set_nonblock fd;
let http_engine =
new Nethttpd_engine.http_engine ~on_request_header () config fd ues in
()
;;
let rec accept ues srv_sock_acc =
(* This function accepts the next connection using the [acc_engine]. After the
* connection has been accepted, it is served by [serve_connection], and the
* next connection will be waited for (recursive call of [accept]). Because
* [server_connection] returns immediately (it only sets the callbacks needed
* for serving), the recursive call is also done immediately.
*)
let acc_engine = srv_sock_acc # accept() in
Uq_engines.when_state ~is_done:(fun (fd,fd_spec) ->
if srv_sock_acc # multiple_connections then (
serve_connection ues fd;
accept ues srv_sock_acc
) else
srv_sock_acc # shut_down())
~is_error:(fun _ -> srv_sock_acc # shut_down())
acc_engine;
;;
let start() =
(* We set up [lstn_engine] whose only purpose is to create a server socket listening
* on the specified port. When the socket is set up, [accept] is called.
*)
printf "Listening on port 8765\n";
flush stdout;
let ues = Unixqueue.create_unix_event_system () in
(* Unixqueue.set_debug_mode true; *)
let opts = { Uq_server.default_listen_options with
Uq_server.lstn_backlog = 20;
Uq_server.lstn_reuseaddr = true } in
let lstn_engine =
Uq_server.listener
(`Socket(`Sock_inet(Unix.SOCK_STREAM, Unix.inet_addr_any, 8765) ,opts)) ues in
Uq_engines.when_state ~is_done:(accept ues) lstn_engine;
(* Start the main event loop. *)
Unixqueue.run ues
;;
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();;
|
