File: netcgi_apache.ml

package info (click to toggle)
ocamlnet 4.1.2-1
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 51,764 kB
  • ctags: 16,446
  • sloc: ml: 148,419; ansic: 10,989; sh: 1,885; makefile: 1,355
file content (730 lines) | stat: -rw-r--r-- 24,185 bytes parent folder | download | duplicates (3)
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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
(* netcgi_apache.ml

   Copyright (C) 2005-2007

     Christophe Troestler
     email: Christophe.Troestler@umh.ac.be
     WWW: http://math.umh.ac.be/an/

   This library is free software; see the file LICENSE for more information.

   This library is distributed in the hope that it will be useful, but
   WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the file
   LICENSE for more details.
*)

open Netcgi_common
open Printf

let log_error msg =
  let zone = Netdate.localzone in
  prerr_endline
    ("[" ^ Netdate.format "%c" (Netdate.create ~zone (Unix.gettimeofday()))
     ^ "] [Netcgi_apache] " ^ msg)


module Conf = Netcgi_apache_mod.Conf
module Handler = Netcgi_apache_mod.Handler


module Apache =
struct
  (* Here we shadow some external functions of the Apache stub to make
     them safer or respecting Netcgi conventions. *)

  module Table = Netcgi_apache_mod.Raw_Apache.Table
  module Server = Netcgi_apache_mod.Raw_Apache.Server
  module Connection = Netcgi_apache_mod.Raw_Apache.Connection

  module Request = struct (* Request_rec functions. *)
    include Netcgi_apache_mod.Raw_Apache.Request

    (* If the return code [i] is an error, raise HTTP with the message [msg]. *)
    let possible_error msg i : unit =
      (* DECLINED -1, DONE -2, OK 0 *)
      if i > 0 then raise(HTTP(Nethttp.http_status_of_int i, msg))

    let setup_client_block r p =
      possible_error "Netcgi_apache.Apache.Request.setup_client_block"
        (setup_client_block r p)

    let get_client_block r =
      try get_client_block r
      with Failure msg -> raise(HTTP(`Internal_server_error, msg))

    let get_client_block_buf r buf ofs len =
      if ofs < 0 || ofs + len > Bytes.length buf then
        invalid_arg "Netcgi_apache.Apache.Request.get_client_block_buf";
      let r = get_client_block_buffer r buf ofs len in
      if r < 0 then
        raise(HTTP(`Internal_server_error,
                  "Netcgi_apache.Apache.Request.get_client_block_buf"))
      else r

    let discard_request_body r =
      possible_error "Netcgi_apache.Apache.Request.discard_request_body"
        (discard_request_body r)

    let get_basic_auth_pw r =
      let i, pw = get_basic_auth_pw r in
      possible_error "Netcgi_apache.Apache.Request.get_basic_auth_pw" i;
      pw

    let rflush r =
      if rflush r < 0 then raise End_of_file
  end

end (* module Apache -------------------------------------------------- *)


(* CGI and Environment objects ---------------------------------------- *)

open Apache

(** Useful functions *)

(* [rm_htspace s] removes heading and trailing spaces of [s]. *)
let rm_htspace =
  let is_space c = c = ' ' || c = '\t' || c = '\n' || c = '\r' in
  fun s -> rm_htspace is_space s 0 (String.length s)

(* Monomorphic version *)
let min (i:int) j = if i <= j then i else j

(* [index_in_range s i0 i1 c] returns the index [j] of the first
   occurrence of [c] in s.[i0 .. i1-1].  If no occurence of [c]
   is found, it will return [i1].  It is assumed that 0 <= i0 and i1
   <= String.length s. *)
let index_in_range s i0 i1 c =
  let rec examine i =
    if i < i1 then
      if Bytes.unsafe_get s i = c then i
      else examine (i+1)
    else i1 in
  examine i0


(************************************************************************)
(** Input channel *)

(* The "stdin" data is here accessible through the "get_client_block"
   function of the [Request.t] type.  We wrap it into a in_object to
   use Netstring parsing functions.

   WARNING: You should NOT create this object if one is not ready to
   read content.  Never create several [in_obj] on the same request.
*)
(* http://www.auburn.edu/docs/apache/misc/client_block_api.html *)

class in_obj (r:Apache.Request.t) : Netchannels.in_obj_channel =
object(self)
  val r = r
  val in_buf = Bytes.create 8192 (* valid: buf.[in0 .. in1-1] *)
  val mutable in0 = 0
  val mutable in1 = 0 (* in1 < 0 indicates the channel is closed *)
  val mutable read = 0 (* number of byte delivered to the user *)

  initializer
    Request.setup_client_block r Request.CHUNKED_ERROR;
    if not(Request.should_client_block r) then (
      (* e.g. for GET request -- should not happen if used correctly *)
      (* XXX Do not terminate the process. *)
      log_error "Netcgi_apache.in_obj: should_client_block returned false \
		for a POST request (ignored)";
(*       failwith "Netcgi_apache.in_obj: should_client_block" *)
    )

  (* [#fill_in_buf] refills [in_buf] if needed (when empty).  After
     this [in0 < in1] or [End_of_file] is raised. *)
  method private fill_in_buf =
    if in0 >= in1 then (
      in0 <- 0;
      in1 <- Request.get_client_block_buf r in_buf 0 8192;
      if in1 = 0 then raise End_of_file;
    )

  method private unsafe_input buf ofs len =
    self#fill_in_buf;
    let r = min len (in1 - in0) in
    Bytes.blit in_buf in0 buf ofs r;
    in0 <- in0 + r;
    read <- read + r;
    r

  (* rec_in_channel *)
  method input buf ofs len =
    if in1 < 0 then raise Netchannels.Closed_channel;
    if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then
      invalid_arg "Netcgi_apache.in_obj#input";
    self#unsafe_input buf ofs len

  method close_in () =
    if in1 < 0 then raise Netchannels.Closed_channel;
    in0 <- 0;
    in1 <- -1

  (* raw_in_channel *)
  method pos_in = read

  (* Convenience methods *)
  method really_input buf ofs len =
    if in1 < 0 then raise Netchannels.Closed_channel;
    if ofs < 0 || len < 0 || ofs + len > Bytes.length buf then
      invalid_arg "Netcgi_apache.in_obj#really_input";
    let ofs = ref ofs
    and len = ref len in
    while !len > 0 do
      let r = self#unsafe_input buf !ofs !len in
      ofs := !ofs + r;
      len := !len - r
    done

  method really_input_string len =
    let b = Bytes.create len in
    self # really_input b 0 len;
    Bytes.unsafe_to_string b

  method input_char () =
    if in1 < 0 then raise Netchannels.Closed_channel;
    self#fill_in_buf;
    let c = Bytes.unsafe_get in_buf in0 in
    in0 <- in0 + 1;
    read <- read + 1;
    c

  method input_byte () = Char.code(self#input_char())

  method input_line () =
    if in1 < 0 then raise Netchannels.Closed_channel;
    let line = ref ""
    and i = ref in1 (* to enter the loop *) in
    while !i = in1 (* '\n' not found *) do
      self#fill_in_buf; (* => in0 < in1 *)
      i := index_in_range in_buf in0 in1 '\n';
      let r = !i - in0 in
      line := !line ^ (Bytes.sub_string in_buf in0 r);
      read <- read + r + 1; (* +1 for '\n' *)
      in0 <- !i + 1; (* skip '\n' *)
    done;
    !line
end


(* When no input is required, we need a dummy object to play the input
   channel role.  The following one will give us appropriate
   information in case of misuse. *)
class dummy_in_obj : Netchannels.in_obj_channel =
object
  method input (_:Bytes.t) (_:int) (_:int) = invalid_arg "dummy_in_obj"
  method close_in () = invalid_arg "dummy_in_obj"
  method pos_in = invalid_arg "dummy_in_obj"
  method really_input (_:Bytes.t) (_:int) (_:int) = invalid_arg "dummy_in_obj"
  method really_input_string (_:int) = invalid_arg "dummy_in_obj"
  method input_char () = invalid_arg "dummy_in_obj"
  method input_byte () = invalid_arg "dummy_in_obj"
  method input_line () = invalid_arg "dummy_in_obj"
end



(************************************************************************)
(** Output channel: though output functions of the request *)

class out_obj (r:Apache.Request.t) : Netchannels.out_obj_channel =
object(self)
  val r = r
  val mutable sent = 0
  val mutable closed = false
    (* At the moment, all buffering is left to Apache. *)

  (* rec_out_channel *)
  method output s ofs len =
    if closed then raise Netchannels.Closed_channel;
    let w = Request.output r s ofs len in
    sent <- sent + w;
    w

  method flush () =
    if closed then raise Netchannels.Closed_channel;
    try Request.rflush r
    with _ -> raise(Sys_error "Netcgi_apache#out_channel#flush: EOF")

  method close_out () = (* Apache closes the channel itself *)
    if not closed then (
      closed <- true;
      try
	self#flush();
      with
	| error ->
	    Netlog.logf `Err
	      "Netcgi_apache: Suppressed error in close_out: %s"
	      (Netexn.to_string error);
    )

  (* raw_out_channel *)
  method pos_out = sent

  (* convenience methods *)
  method output_char c =
    if closed then raise Netchannels.Closed_channel;
    Request.print_char r c;
    sent <- sent + 1

  method output_byte i = self#output_char(Char.unsafe_chr(i land 0xFF))

  method private unsafe_really_output s ofs len =
    let len = ref len
    and ntries = ref 0 (* avoid infinite loop *) in
    while !len > 0 && !ntries < 100 do
      let w = Request.output r s ofs !len (* checks bounds *) in
      sent <- sent + w;
      len := !len - w; (* if not = 0, try again *)
      incr ntries;
    done;
    if !len > 0 then failwith "Netcgi_apache#out_channel#really_output"

  method output_string s =
    if closed then raise Netchannels.Closed_channel;
    self#unsafe_really_output (Bytes.unsafe_of_string s) 0 (String.length s)

  method output_bytes s =
    if closed then raise Netchannels.Closed_channel;
    self#unsafe_really_output s 0 (Bytes.length s)

  method output_buffer b = self#output_string(Buffer.contents b)

  method really_output s ofs len =
    if closed then raise Netchannels.Closed_channel;
    if ofs < 0 || len < 0 || ofs + len > Bytes.length s then
      invalid_arg "Netcgi_apache#out_channel#really_output";
    self#unsafe_really_output s ofs len

  method really_output_string s ofs len =
    if closed then raise Netchannels.Closed_channel;
    if ofs < 0 || len < 0 || ofs + len > String.length s then
      invalid_arg "Netcgi_apache#out_channel#really_output_string";
    self#unsafe_really_output (Bytes.unsafe_of_string s) ofs len

  method output_channel ?len in_obj =
    if closed then raise Netchannels.Closed_channel;
    let buf = Bytes.create 8192 in
    match len with
    | None -> (* read till the end *)
	(try
	   while true do
	     let r = in_obj#input buf 0 8192 in
	     if r = 0 then raise Sys_blocked_io;
	     self#unsafe_really_output buf 0 r;
	   done
	 with End_of_file -> ())
    | Some len -> (* read at most that many bytes *)
	(try
	   let len = ref len in
	   while !len > 0 do
	     let r = in_obj#input buf 0 (min 8192 !len) in
	     if r = 0 then raise Sys_blocked_io;
	     self#unsafe_really_output buf 0 r;
	     len := !len - r
	   done
	 with End_of_file -> ())
end


(************************************************************************)
(** Header classes bound to Apache table *)

(* Apache already has a representation for MIME headers so we bind
   directly to them instead of using OcamlNet [Netmime] module.  The
   Apache functions already treat keys case-insensitively as we want.
*)

class mime_header ?(ro=false) table : Netmime.mime_header =
object (self)
  val ro = ro
  val t = table

  (* Get *)

  method ro = ro
  method fields = Apache.Table.fields t
  method field name = Apache.Table.get t name
  method multiple_field name = Apache.Table.get_all t name

  (* Set *)

  method private immutable =
    raise (Netmime.Immutable "Netcgi_apache.mime_header");

  method set_fields h =
    if ro then self#immutable;
    Apache.Table.clear t;
    List.iter (fun (k,v) -> Apache.Table.add t k v) h

  method update_field name v =
    if ro then self#immutable;
    Apache.Table.set t name v

  method update_multiple_field name vl =
    if ro then self#immutable;
    match vl with
    | [] -> Apache.Table.unset t name
    | v :: tl ->
	Apache.Table.set t name v;
	List.iter (fun v -> Apache.Table.add t name v) tl

  method delete_field name =
    if ro then self#immutable;
    Apache.Table.unset t name

  (* Access methods for frequent standard fields *)

(*
  method content_length() =
    int_of_string(rm_htspace(self#field "content-length"))
  method content_type() =
    Netmime_string.scan_mime_type_ep (self#field "content-type") []
  method content_disposition() =
    Netmime_string.scan_mime_type_ep (self#field "content-disposition") []
  method content_transfer_encoding() =
    String.lowercase(self#field "content-transfer-encoding")
 *)
end


(************************************************************************)
(** Environment *)

(* The environment properties does not come from a list that we have
   to parse.  Rather, properties come from various entries in the
   [request_rec] structure, i.e. various functions in the
   [Apache.Request] module.
*)
class cgi_environment ~config r : Netcgi.cgi_environment =
  let path_info = try Request.path_info r with Not_found -> "" in
object(self)
  inherit Netcgi_common.cgi_environment ~config
    ~properties:[] ~input_header:[] (new out_obj r)

  (* Properties settable by Request functions.  Store their initial value. *)
  val script_name =
    let s = try Request.uri r with Not_found -> "" in
    if Filename.check_suffix s path_info then
      Filename.chop_suffix s path_info (* suppress path_info *)
    else s
  val path_info = path_info
  val r_filename = try Request.filename r with Not_found -> ""
  val query_string = try Request.args r with Not_found -> ""


  val input_header = new mime_header ~ro:true (Request.headers_in r)
  val output_header = new mime_header ~ro:false (Request.headers_out r)
    (* XXX Should we use [err_headers_out] because they persist on
       errors and across internal redirect?  What about other connectors? *)
  val r = r (* must be last for the above [r] to be the arg. *)
  val mutable properties_list = lazy(assert false)
  val mutable input_content_type = lazy(assert false)

  initializer
    (* Content-type MSIE bug fix has not been applied; do it now.  *)
    input_content_type <- lazy(
      let work_around =
	List.mem `MSIE_Content_type_bug self#config.workarounds
	&& (try is_MSIE(self#user_agent) with Not_found -> false) in
      let ct = self#input_header_field "content-type" in
      let ct = if work_around then fix_MSIE_Content_type_bug ct else ct in
      Netmime_string.scan_mime_type_ep ct []
    );
    (* We probably do not want the list of all properties, so compute
       it on demand only. *)
    properties_list <- lazy (
      let l =
	[ ("GATEWAY_INTERFACE", self#cgi_gateway_interface);
	  ("SERVER_NAME", self#cgi_server_name);
	  ("SERVER_PROTOCOL", self#cgi_server_protocol);
	  ("SERVER_SOFTWARE", self#cgi_server_software);
	  ("SERVER_ADMIN", Server.admin(Request.server r));
	  ("REQUEST_METHOD", self#cgi_request_method);
	  ("SCRIPT_NAME", self#cgi_script_name);
	  ("PATH_INFO", self#cgi_path_info);
	  ("PATH_TRANSLATED", self#cgi_path_translated);
	  ("AUTH_TYPE", self#cgi_auth_type);
	  ("REMOTE_ADDR", self#cgi_remote_addr);
	  ("REMOTE_HOST", self#cgi_remote_host);
	  ("REMOTE_USER", self#cgi_remote_user);
	  ("REMOTE_IDENT", self#cgi_remote_ident);
	  ("QUERY_STRING", self#cgi_query_string);
	  ("SCRIPT_FILENAME", r_filename);
	] in
      let l = match self#cgi_server_port with
	| None -> l
	| Some p -> ("SERVER_PORT", string_of_int(p)) :: l in
      l
    )

  (* CGI properties *)

  method cgi_properties = Lazy.force properties_list
  method cgi_property ?default name =
    try List.assoc name (Lazy.force properties_list)
    with Not_found -> (match default with
    | None -> raise Not_found
    | Some d -> d)

  (* None of the following methods should raise [Not_found].  Return
     "" instead. *)
  method cgi_gateway_interface = Conf.gateway_interface
  method cgi_server_name = try Request.hostname r with Not_found -> ""
  method cgi_server_port = Some(Request.port r)
  method cgi_server_protocol = try Request.protocol r with Not_found -> ""
  method cgi_server_software = Conf.server_software
  method cgi_request_method = try Request.method_name r with Not_found -> ""
    (* Beware that it is used by the [Netcgi_common.cgi_with_args] to
       pass a it to [[Netcgi_common.cgi] to set the [out_channel] to
       an appropriate value. *)
  method cgi_script_name = script_name
  method cgi_path_info = path_info
  method cgi_path_translated = "" (* FIXME: don't know how to get it *)
  method cgi_auth_type = try Request.auth_type r with Not_found -> ""
  method cgi_remote_addr =
    try Connection.remote_ip(Request.connection r) with Not_found -> ""
  method cgi_remote_host =
    try Connection.remote_host(Request.connection r) with Not_found -> ""
  method cgi_remote_user = try Request.user r with Not_found -> ""
  method cgi_remote_ident = "" (* FIXME: is it only supported? *)
  method cgi_query_string = query_string
    (* method protocol is inherited and use [server_protocol]; OK *)
  method cgi_https = false (* FIXME: don't know how to get it *)


  (* Input -- other methods are defined in terms of [input_header], so
     no nedd to override them. *)
  method input_header = input_header

  (* Output -- again other methods are defined in terms of
     [output_header] and do not need to be overridden. *)
  method output_header = output_header

  method send_output_header () =
    if header_not_sent then (
      (* Must treat Status specially *)
      (try
	  let st = int_of_string(self#output_header#field "Status") in
	  Request.set_status r st
        with Not_found | Failure _ -> ());
      (* Must treat Content-Type specially *)
      Request.set_content_type r
	(try self#output_header#field "Content-Type"
	  with Not_found -> "text/html"
	    (* In [Netcgi_common.environment], it was decided to have a
	       default Content-type. *)
	);
      Request.send_http_header r;
      header_not_sent <- false
    )

(* method out_channel is fine as inherited *)

(* method log_error: funny as it is, printing on stderr is fine for
   Apache modules. *)
end


(************************************************************************)
(** CGI abstraction *)

(* Enriched CGI class *)
class type cgi =
object
  inherit Netcgi.cgi
  method request : Apache.Request.t
end

class cgi_mod (r:Request.t) env op request_method args : cgi =
object
  inherit Netcgi_common.cgi env op request_method args  as super

  val r = r
  method request = r
end


exception Error of Nethttp.http_status * string * string
  (* [Error(status, log-msg, user-msg)]: errors raised before the
     handler is created. *)


(* This will be used by the script to set its entry point (function to
   be run) when loaded with [Dynlink]. *)
let script_run = ref None

(* Load a file and return the function to run. *)
let load_file filename =
  script_run := None;
  (try  Dynlink.loadfile_private filename;
   with
   | Dynlink.Error e ->
       raise(Error(`Internal_server_error,
		   filename ^ ": Dynlink.Error: " ^ Dynlink.error_message e,
		   "Couldn't load the script."))
   | e -> raise(Error(`Internal_server_error,
		      filename ^ ": " ^ Netexn.to_string e,
		      "Couldn't load the script.")));
  (* If the file was loaded and thus the toplevel code executed,
     [current_script] should now be [Some handler]. *)
  match !script_run with
  | None ->
      raise(Error(`Not_found,
		  "You must register your main function with Netcgi_apache.run!",
		  "No entry point in the script."))
  | Some script -> script


(* Tells wich function of the script is the one to run on each
   request.  This is to be only called 1 time per script.  Exceptions
   will be dealt with in the handler (see below).  *)
let run ?(config=Netcgi.default_config)
    ?(output_type=(`Direct "" : Netcgi.output_type))
    ?(arg_store=(fun _ _ _ -> `Automatic : Netcgi.arg_store))
    ?(exn_handler=(fun _ f -> f()))
    f =
  if !script_run <> None then
    raise(Error(`Internal_server_error,
	       "Netcgi_apache.run should only be called once!",
	       "Multiple entry points in the script."));
  let script r =
    (* Netcgi_apache specific environment -- including output object *)
    let env = new cgi_environment ~config r in
    exn_handler_default env ~exn_handler
      (fun () ->
        let in_obj =
	  match env#cgi_request_method with
	  | "POST" | "PUT" ->
	      new in_obj r (* => only created if necessary *)
	  | _ ->
	      Request.discard_request_body r;
	      new dummy_in_obj (* raise an exception if used *)
        in
        let cgi =
	  cgi_with_args (new cgi_mod r) env output_type in_obj arg_store in
        (try
	    f cgi;
            cgi#out_channel#commit_work();
	    cgi#finalize()
          with e when config.default_exn_handler ->
            cgi#finalize(); raise e);
        None (* no "special" internal exception *)
      )
      ~finally:(fun () ->
        (try env#out_channel#close_out() with _ -> ()); (* flush *)
      );
    Handler.OK
  in
  (* Register the main function *)
  script_run := Some script




(************************************************************************)
(** Registry *)

(* This part is loosely based on mod_caml Registry *)


(* This is an error page for the exceptions launched before the
   environment object can be created. *)
let error_page r status log_msg user_msg =
  (* Log the error *)
  let code = Nethttp.int_of_http_status status in
  log_error(Printf.sprintf  "%s (Status %i)" log_msg code);
  (* Display an error page *)
  Request.set_status r code;
  Request.set_content_type r "text/html";
  let t = Request.headers_out r in
  Apache.Table.set t "Cache-control" "max-age=3600";
  Apache.Table.add t "Cache-control" "must-revalidate";
  let secs = Netdate.mk_mail_date(Unix.time() +. 3600.) in
  Apache.Table.set t "Expires" secs;
  Request.send_http_header r;
  if not(Request.header_only r) then (
    let out s = ignore(Request.print_string r s) in
    out "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.0//EN\" \
	\"http://www.w3.org/TR/REC-html40/strict.dtd\">\n";
    out "<html xmlns=\"http://www.w3.org/1999/xhtml\" \
	xml:lang=\"en\" lang=\"en\">
<head>
<meta name=\"generator\" content=\"OCamlNet (http://ocamlnet.sf.net)\">
<style>
  p.msg { color: black; background-color: #cccccc; padding: 1ex; }
  h2 { font-size: large; }
</style>
</head>
<body>\n";
    let info = Nethttp.string_of_http_status status in
    out ("<h1>Netcgi_apache &mdash; " ^ info ^ "</h1>\n");
    out "<p class=\"msg\">";
    out user_msg;
    out "</p>\n";
    out "<p>Additional information is available in the web server \
	error log file.</p>\n";
    out "</body>\n</html>\n";
    ignore(Request.rflush r)
  )


(* Table of scripts we have already loaded.  Maps filename ->
   (handler, mtime) so we can reload the file if the mtime has
   changed.  *)
let loaded_scripts = Hashtbl.create 32


(* Handler for requests. *)
let handler r =
  try
    (* Without [filename] or [mtime] we cannot do anything so we
       decline the request. *)
    let filename =
      try Apache.Request.filename r
      with Not_found ->	raise(Error(`Not_found,
				    "Request.filename not found!",
				    "No such script.")) in
    let mtime =
      match Apache.Request.finfo r with
      | Some finfo -> finfo.Unix.st_mtime
      | None ->
	  raise(Error(`Not_found,
		      sprintf "Request.finfo not found.  It probably means \
			that the file %S does not exist." filename,
		      "No such script.")) in
    (* Get the script main function for this file. *)
    let script =
      try
	let (old_handler, old_mtime) = Hashtbl.find loaded_scripts filename in
	if old_mtime < mtime then (
          (* Reload the file. *)
	  let handler = load_file filename in
	  Hashtbl.replace loaded_scripts filename (handler, mtime);
	  handler
	) else
	  old_handler
      with Not_found ->
	(* Load the file for the first time. *)
	let handler = load_file filename in
	Hashtbl.add loaded_scripts filename (handler, mtime);
	handler in

    (* Run the script. *)
    script r
  with Error(status, log_msg, user_msg) ->
    error_page r status log_msg user_msg;
    (* Returning [Handler.DECLINED] is not fine.  Indeed, Apache then
       tries his own handler and then propose to download the script
       -- this is a security problem! *)
    Handler.DONE


let () =
  (* We are in the same module than the Handler (no bytecode to load),
     so specify the full module name to use. *)
  Handler.register handler "bytecode"