← Back to branch summary

~ubuntu-branches/ubuntu/trusty/ocamlnet/trusty

« back to all changes in this revision

Viewing changes to src/nethttpd-for-netcgi1/nethttpd_plex.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-09-02 14:12:33 UTC
  • mfrom: (18.2.3 sid)
  • Revision ID: james.westby@ubuntu.com-20110902141233-zbj0ygxb92u6gy4z
Tags: 3.4-1
http://bugs.debian.org/637147
* New upstream release
  - add a new NetcgiRequire directive to ease dependency management
    (Closes: #637147)
  - remove patches that were applied upstream:
    + Added-missing-shebang-lines-in-example-shell-scripts
    + Try-also-ocamlc-for-POSIX-threads

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/nethttpd-for-netcgi1/nethttpd_plex.ml
1
 
(* $Id: nethttpd_plex.ml 1101 2007-04-09 11:02:10Z gerd $ *)
2
 
 
3
 
open Nethttpd_services
4
 
open Netplex_types
5
 
 
6
 
type config_log_error =
7
 
    Unix.sockaddr option -> Unix.sockaddr option -> Nethttp.http_method option -> Nethttp.http_header option -> string -> unit
8
 
 
9
 
class nethttpd_processor mk_config srv : Netplex_types.processor =
10
 
object(self)
11
 
  method process ~when_done (container : Netplex_types.container) fd proto =
12
 
    let error_logger _ peeraddr_opt meth_opt _ msg =
13
 
      let s =
14
 
        Printf.sprintf "[%s] [%s] %s"
15
 
          ( match peeraddr_opt with
16
 
              | Some(Unix.ADDR_INET(addr,port)) ->
17
 
                  Unix.string_of_inet_addr addr
18
 
                | Some(Unix.ADDR_UNIX path) ->
19
 
                    path
20
 
                | None ->
21
 
                    "-"
22
 
          )
23
 
          ( match meth_opt with
24
 
              | (Some(name,uri)) ->
25
 
                  name ^ " " ^ uri
26
 
              | None ->
27
 
                  "-"
28
 
          )
29
 
          msg
30
 
      in
31
 
       container # log `Err s
32
 
    in
33
 
    let config = mk_config error_logger in
34
 
    ( try
35
 
        Nethttpd_reactor.process_connection config fd srv
36
 
      with
37
 
        | err ->
38
 
            container # log `Err ("Uncaught exception: " ^ 
39
 
                                    Printexc.to_string err)
40
 
    );
41
 
    when_done()
42
 
 
43
 
  method receive_message _ _ _ = ()
44
 
  method receive_admin_message _ _ _ = ()
45
 
  method shutdown() = ()
46
 
  method post_add_hook _ = ()
47
 
  method post_rm_hook _ = ()
48
 
  method pre_start_hook _ _ _ = ()
49
 
  method post_start_hook _ = ()
50
 
  method pre_finish_hook _ = ()
51
 
  method post_finish_hook _ _ _ = ()
52
 
  method supported_ptypes = [ `Multi_processing ; `Multi_threading ]
53
 
  method global_exception_handler _ = false
54
 
end
55
 
 
56
 
let nethttpd_processor mk_config srv =
57
 
  new nethttpd_processor mk_config srv
58
 
 
59
 
 
60
 
let is_options_request env =
61
 
  env # cgi_request_method = "OPTIONS" && env # cgi_request_uri = "*"
62
 
 
63
 
let is_any_request env =
64
 
  true
65
 
 
66
 
let ws_re = Pcre.regexp "[ \r\t\n]+"
67
 
 
68
 
let split_ws s =
69
 
  Netstring_pcre.split ws_re s
70
 
 
71
 
let name_port_re = Pcre.regexp "^([^:]+):([0-9]+)$"
72
 
 
73
 
let split_name_port s =
74
 
  match Netstring_pcre.string_match name_port_re s 0 with
75
 
    | Some m ->
76
 
        let name = Netstring_pcre.matched_group m 1 s in
77
 
        let port = Netstring_pcre.matched_group m 2 s in
78
 
        (name, int_of_string port)
79
 
    | None ->
80
 
        failwith "Bad name:port specifier"
81
 
 
82
 
let create_processor config_cgi handlers ctrl_cfg cfg addr =
83
 
 
84
 
  let req_str_param addr name =
85
 
    try
86
 
      cfg#string_param (cfg # resolve_parameter addr name)
87
 
    with
88
 
      | Not_found ->
89
 
          failwith ("Missing parameter: " ^ cfg#print addr ^ "." ^ name) in
90
 
 
91
 
  let opt_str_param addr name =
92
 
    try
93
 
      Some(cfg#string_param (cfg # resolve_parameter addr name))
94
 
    with
95
 
      | Not_found -> None in
96
 
 
97
 
  let float_param default addr name =
98
 
    try
99
 
      cfg#float_param (cfg # resolve_parameter addr name)
100
 
    with
101
 
      | Not_found -> default in
102
 
 
103
 
  let bool_param addr name =
104
 
    try
105
 
      cfg#bool_param (cfg # resolve_parameter addr name)
106
 
    with
107
 
      | Not_found -> false in
108
 
 
109
 
  let rec sub_service outermost_flag uri_path addr =
110
 
    let host_sects = cfg # resolve_section addr "host" in
111
 
    let uri_sects = cfg # resolve_section addr "uri" in
112
 
    let method_sects = cfg # resolve_section addr "method" in
113
 
    let service_sects = cfg # resolve_section addr "service" in
114
 
    match (host_sects, uri_sects, method_sects, service_sects) with
115
 
      | [], [], [], [] ->
116
 
          linear_distributor []   (* Forces a 404 response *)
117
 
      | _, [], [], [] ->
118
 
          let hosts =
119
 
            List.map (host_sub_service uri_path) host_sects in
120
 
          host_distributor hosts
121
 
      | [], _, [], [] ->
122
 
          if outermost_flag then
123
 
            failwith ("Outermost subsection must be 'host': " ^ cfg#print addr);
124
 
          let uris =
125
 
            List.map (uri_sub_service uri_path) uri_sects in
126
 
          uri_distributor uris
127
 
      | [], [], _, [] ->
128
 
          if outermost_flag then
129
 
            failwith ("Outermost subsection must be 'host': " ^ cfg#print addr);
130
 
          let methods =
131
 
            List.map (method_sub_service uri_path) method_sects in
132
 
          method_distributor methods
133
 
      | [], [], [], _ ->
134
 
          if outermost_flag then
135
 
            failwith ("Outermost subsection must be 'host': " ^ cfg#print addr);
136
 
          ( match service_sects with
137
 
              | [] -> assert false
138
 
              | [service_sect] ->
139
 
                  service uri_path service_sect
140
 
              | _ ->
141
 
                  failwith ("Only one 'service' subsection is permitted: " ^ cfg#print addr);
142
 
          )
143
 
      | _ ->
144
 
          failwith("Only one type of subsections host/uri/method/service is allowed: " ^ cfg#print addr)
145
 
 
146
 
  and sub_service_ac uri_path addr =
147
 
    (* With access control *)
148
 
    let srv = sub_service false uri_path addr in
149
 
    let access_sects = cfg # resolve_section addr "access" in
150
 
    List.fold_left
151
 
      (fun srv access_sect ->
152
 
         access_control access_sect srv)
153
 
      srv
154
 
      access_sects
155
 
 
156
 
  and host_sub_service uri_path addr =
157
 
    cfg # restrict_subsections addr [ "host"; "uri"; "method"; "service";
158
 
                                      "access" ];
159
 
    cfg # restrict_parameters addr [ "names"; "pref_name"; "pref_port" ];
160
 
 
161
 
    let names_str = req_str_param addr "names" in
162
 
    let names = 
163
 
      List.map
164
 
        (fun s ->
165
 
           try split_name_port s
166
 
           with
167
 
             | Failure m ->
168
 
                 failwith (m ^ ": " ^ cfg#print addr ^ ".names")
169
 
        )
170
 
        (split_ws names_str) in
171
 
    let host_def =
172
 
      { server_pref_name = opt_str_param addr "pref_name";
173
 
        server_pref_port =
174
 
          ( try Some(cfg # int_param
175
 
                       (cfg # resolve_parameter addr "pref_port"))
176
 
            with Not_found -> None
177
 
          );
178
 
        server_names = names;
179
 
        server_addresses =
180
 
          ( List.map
181
 
              (fun (_, port) -> (Unix.inet_addr_any, port))
182
 
              (List.filter
183
 
                 (fun (name, _) -> name = "*")
184
 
                 names)
185
 
          )
186
 
      } in
187
 
    let srv = sub_service_ac uri_path addr in
188
 
    (host_def, srv)
189
 
 
190
 
  and uri_sub_service _ addr =
191
 
    cfg # restrict_subsections addr [ "host"; "uri"; "method"; "service";
192
 
                                      "access" ];
193
 
    cfg # restrict_parameters addr [ "path" ];
194
 
    let path = req_str_param addr "path" in
195
 
    let srv = sub_service_ac path (* sic! *) addr in
196
 
    (path, srv)
197
 
 
198
 
  and method_sub_service uri_path addr =
199
 
    cfg # restrict_subsections addr [ "host"; "uri"; "method"; "service";
200
 
                                      "access" ];
201
 
    cfg # restrict_parameters addr [ "allow"; "deny" ];
202
 
    let allow_opt = opt_str_param addr "allow" in
203
 
    let deny_opt = opt_str_param addr "deny" in
204
 
    let filter =
205
 
      match (allow_opt, deny_opt) with
206
 
        | (Some host_list), None ->
207
 
            `Limit (split_ws host_list)
208
 
        | None, (Some host_list) ->
209
 
            `Limit_except (split_ws host_list)
210
 
        | None, None ->
211
 
            failwith ("Missing parameter 'allow' or 'deny': " ^ cfg#print addr)
212
 
        | _, _ ->
213
 
            failwith ("It is forbidden to specify both 'allow' and 'deny': " ^
214
 
                        cfg#print addr)
215
 
    in
216
 
    let srv = sub_service_ac uri_path addr in
217
 
    (filter, srv)
218
 
 
219
 
  and access_control addr srv =
220
 
    let typ = req_str_param addr "type" in
221
 
    match typ with
222
 
      | "host" -> host_access_control addr srv
223
 
      | _ ->
224
 
          failwith ("Unknown access control type: " ^ cfg#print addr ^ ".type")
225
 
 
226
 
  and host_access_control addr srv =
227
 
    cfg # restrict_subsections addr [ ];
228
 
    cfg # restrict_parameters addr [ "type"; "allow"; "deny" ];
229
 
    let allow_opt = opt_str_param addr "allow" in
230
 
    let deny_opt = opt_str_param addr "deny" in
231
 
    let filter =
232
 
      match (allow_opt, deny_opt) with
233
 
        | (Some host_list), None ->
234
 
            `Allow (split_ws host_list)
235
 
        | None, (Some host_list) ->
236
 
            `Deny (split_ws host_list)
237
 
        | None, None ->
238
 
            failwith ("Missing parameter 'allow' or 'deny': " ^ cfg#print addr)
239
 
        | _, _ ->
240
 
            failwith ("It is forbidden to specify both 'allow' and 'deny': " ^
241
 
                        cfg#print addr) in
242
 
    ac_by_host (filter, srv)
243
 
 
244
 
  and service uri_path addr =
245
 
    let typ = req_str_param addr "type" in
246
 
    match typ with
247
 
      | "file"    -> file_service uri_path addr
248
 
      | "dynamic" -> dynamic_service addr
249
 
      | _ ->
250
 
          failwith ("Unknown service type: " ^ cfg#print addr ^ ".type")
251
 
 
252
 
  and file_service uri_path addr =
253
 
    cfg # restrict_subsections addr [ "media_type" ];
254
 
    cfg # restrict_parameters addr [ "type"; "media_types_file";
255
 
                                     "docroot"; "default_media_type";
256
 
                                     "enable_gzip"; "index_files";
257
 
                                     "enable_listings";
258
 
                                     "hide_from_listings" ];
259
 
    let suffix_types =
260
 
      ( List.map
261
 
          (fun addr ->
262
 
             cfg # restrict_subsections addr [];
263
 
             cfg # restrict_parameters addr [ "suffix"; "type" ];
264
 
             (req_str_param addr "suffix", req_str_param addr "type")
265
 
          )
266
 
          (cfg # resolve_section addr "media_type")
267
 
      ) @
268
 
        ( match opt_str_param addr "media_types_file" with
269
 
            | None -> []
270
 
            | Some f ->
271
 
                read_media_types_file f
272
 
        ) in
273
 
    let spec =
274
 
      { file_docroot = req_str_param addr "docroot";
275
 
        file_uri = ( match opt_str_param addr "uri" with
276
 
                       | None -> uri_path
277
 
                       | Some uri -> uri );
278
 
        file_suffix_types = suffix_types;
279
 
        file_default_type = 
280
 
          ( match opt_str_param addr "default_media_type" with
281
 
              | None -> "text/plain"
282
 
              | Some t -> t);
283
 
        file_options = 
284
 
          ( if bool_param addr "enable_gzip" then
285
 
              [ `Enable_gzip ] 
286
 
            else 
287
 
              []
288
 
          ) @
289
 
          ( match opt_str_param addr "index_files" with
290
 
              | None -> []
291
 
              | Some s -> [ `Enable_index_file (split_ws s) ]
292
 
          ) @
293
 
          ( if bool_param addr "enable_listings" then
294
 
              let hide = 
295
 
                match opt_str_param addr "hide_from_listings" with
296
 
                  | None -> []
297
 
                  | Some s -> split_ws s in
298
 
              let l = simple_listing ~hide in
299
 
              [ `Enable_listings l ]
300
 
            else
301
 
              []
302
 
          )
303
 
      } in
304
 
    Nethttpd_services.file_service spec
305
 
 
306
 
  and dynamic_service addr =
307
 
    cfg # restrict_subsections addr [];
308
 
    cfg # restrict_parameters addr [ "type"; "handler" ];
309
 
    let handler_name = req_str_param addr "handler" in
310
 
    let srv =
311
 
      try
312
 
        List.assoc handler_name handlers
313
 
      with
314
 
        | Not_found ->
315
 
            failwith ("Unknown handler `" ^ handler_name ^ "' in param " ^ 
316
 
                        cfg#print addr ^ ".handler") in
317
 
    Nethttpd_services.dynamic_service srv
318
 
  in
319
 
 
320
 
  cfg # restrict_subsections addr [ "host"; "uri"; "method"; "service" ];
321
 
  cfg # restrict_parameters addr [ "type"; "timeout"; "timeout_next_request" ];
322
 
 
323
 
  let srv =
324
 
    linear_distributor
325
 
      [ is_options_request, options_service();
326
 
        is_any_request, sub_service true "/" addr
327
 
      ] in
328
 
 
329
 
  let timeout = float_param 300.0 addr "timeout" in
330
 
  let timeout_next_request = float_param 15.0 addr "timeout_next_request" in
331
 
 
332
 
  let mk_config cle =
333
 
    (object
334
 
       method config_reactor_synch = `Write
335
 
       method config_timeout_next_request = timeout_next_request
336
 
       method config_timeout = timeout
337
 
       method config_cgi = config_cgi
338
 
       method config_error_response n = 
339
 
         (* TODO *)
340
 
         "<html><body>Error " ^ string_of_int n ^ "</body></html>"
341
 
       method config_log_error = cle
342
 
       method config_max_reqline_length = 32768
343
 
       method config_max_header_length = 65536
344
 
       method config_max_trailer_length = 65536
345
 
       method config_limit_pipeline_length = 1
346
 
       method config_limit_pipeline_size = 65536
347
 
       method config_announce_server = `Ocamlnet
348
 
         (* TODO *)
349
 
     end
350
 
    ) in
351
 
 
352
 
  nethttpd_processor
353
 
    mk_config
354
 
    srv
355
 
;;
356
 
 
357
 
class nethttpd_factory ?(config_cgi = Netcgi1_compat.Netcgi_env.default_config) 
358
 
                       ?(handlers=[]) () : processor_factory =
359
 
object
360
 
  method name = "nethttpd"
361
 
  method create_processor ctrl_cfg cfg addr =
362
 
    create_processor config_cgi handlers ctrl_cfg cfg addr
363
 
end
364
 
 
365
 
let nethttpd_factory ?config_cgi ?handlers () =
366
 
  new nethttpd_factory ?config_cgi ?handlers ()