(*
* <COPYRIGHT>
* Copyright 2002 Joachim Schrod Network and Publication Consultance GmbH, Gerd Stolpmann
*
* <GPL>
* This file is part of WDialog.
*
* WDialog is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* WDialog 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
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with WDialog; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
* </>
*)
(* $Id: wd_run_cgi.ml,v 3.6 2003-01-15 23:04:47 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_types
open Netcgi
open Netchannels
let adjust_gc () =
let gc = Gc.get() in
gc.Gc.space_overhead <- 100;
gc.Gc.minor_heap_size <- 256 * 1024;
Gc.set gc
;;
let print_error (ch:out_obj_channel) exc =
let s = Printexc.to_string exc in
let out = ch # output_string in
out "<html><body><h1>Software error</h1>\n";
out "<tt>";
out (Netencoding.Html.encode_from_latin1 s);
out "</tt></body></html>\n"
;;
let processing name hdr =
`Automatic
;;
let operating_type =
`Transactional
(fun _ ch ->
new Netchannels.buffered_trans_channel ch)
let run
?(charset = `Enc_iso88591)
?script
?self_url
?uifile
?session_manager
?(no_cache = true)
?(error_page = print_error)
?cgi_config
?(output_type = operating_type)
?response_header
?(reg = (fun _ -> ()))
() =
Netcgi_cgi.run
?config:cgi_config
~output_type
(fun cgi ->
begin try
let suggested_script_file_name, suggested_url =
match script with
None ->
let script_path =
cgi # environment # cgi_script_name in
let b = Filename.basename script_path in
if b = "" then "index.cgi", "" else b, b
| Some s ->
s, Filename.basename s
in
let url =
match self_url with
None ->
"./" ^ suggested_url
| Some u ->
u
in
let ui_file_name =
match uifile with
None ->
( try
Filename.chop_extension suggested_script_file_name ^ ".ui"
with _ ->
"index.ui"
)
| Some f ->
f
in
(* Load the UI term: *)
let ui_compiled_file_name =
Filename.chop_extension ui_file_name ^ ".ui.bin" in
let app =
if Sys.file_exists ui_compiled_file_name then
Wd_transform.load_uiapplication ~charset ui_compiled_file_name
else
Wd_transform.parse_uiapplication ~charset ui_file_name
in
let cache =
match cgi # request_method with
`GET -> `No_cache
| `POST -> if no_cache then `No_cache else `Unspecified
| _ -> assert false
in
let charset_s =
Netconversion.string_of_encoding (charset :> Netconversion.encoding) in
let response_header =
match response_header with
None -> { rh_status = `Ok;
rh_content_type = "text/html; charset=" ^ charset_s;
(* Note: Some browsers (e.g. Mozilla-0.9.6) do not like
* quotes around charset
*)
rh_cache = cache;
rh_filename = None;
rh_language = None;
rh_script_type = None;
rh_style_type = None;
rh_set_cookie = [];
rh_fields = [];
}
| Some rh -> rh
in
let universe = new Wd_universe.universe app in
reg universe;
Wd_cycle.process_request ?session_manager ~self_url:url ~response_header
universe cgi;
with
exc ->
cgi # output # rollback_work();
cgi # set_header ~status:`Internal_server_error ~cache:`No_cache ();
error_page (cgi#output :> out_obj_channel) exc;
(* may raise another exception! *)
end;
cgi # output # commit_work();
cgi # finalize()
)
;;
(* ======================================================================
* History:
*
* $Log: wd_run_cgi.ml,v $
* Revision 3.6 2003-01-15 23:04:47 stolpmann
* New option ~uifile
*
* Revision 3.5 2003/01/04 21:55:25 stolpmann
* new record response_header
*
* Revision 3.4 2002/03/19 22:09:29 stolpmann
* Using `Automatic.
*
* Revision 3.3 2002/02/26 16:01:12 stolpmann
* Fix: Error pages are not cached.
*
* Revision 3.2 2002/02/14 16:15:21 stolpmann
* Added copyright notice.
*
* Revision 3.1 2002/02/12 20:29:20 stolpmann
* Initial release at sourceforge.
*
* Revision 1.6 2002/02/06 00:14:00 gerd
* Updates to ocamlnet-0.92
*
* Revision 1.5 2002/02/05 18:43:55 gerd
* It is now possible to pass the session_manager
*
* Revision 1.4 2002/01/30 15:14:10 gerd
* New: ~charset
*
* Revision 1.3 2002/01/14 15:03:24 gerd
* Major change: Typing has been completely revised, and almost
* every tiny thing has now a new type. Also renamed a lot.
*
* Revision 1.2 2000/12/06 15:26:47 gerd
* Support for the ~self_url argument.
*
* Revision 1.1 2000/11/30 18:29:07 gerd
* Initial revision
*
*)
