(*
* <COPYRIGHT>
* Copyright 2003 Gerd Stolpmann
*
* <GPL>
* This file is part of WTimer.
*
* WTimer 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.
*
* WTimer 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: init.ml,v 1.5 2003/03/23 11:59:14 gerd Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_dialog
open Wd_types
open Db_types.Types
open Db_types
open Db.Types
(**********************************************************************)
(* Definition of additional output encodings *)
(**********************************************************************)
(* These functions map strings to strings in order to beautify the
* displayed text. They can be called from UI language by the
* <ui:encode> element.
*)
(* (1) Mappings from dates to strings: Input is an ISO date in the
* format YYYY-MM-DD, e.g. 2002-08-31
*)
let enc_year date_str =
(* for <ui:encode enc="year">: outputs the year only *)
let date = Date.from_string date_str in
let year = (Date.access date).year in
string_of_int year
;;
let enc_mday date_str =
(* for <ui:encode enc="mday">: output is the day number *)
let date = Date.from_string date_str in
let mday = (Date.access date).mday in
string_of_int mday
;;
let enc_mday_en date_str =
(* for <ui:encode enc="mday-en">: output is the ordinal day number *)
let s = enc_mday date_str in
match s.[ String.length s - 1] with
'1' -> if s="11" then s ^ "th" else s ^ "st"
| '2' -> if s="12" then s ^ "th" else s ^ "nd"
| '3' -> if s="13" then s ^ "th" else s ^ "rd"
| _ -> s ^ "th"
;;
let tm_of_date date =
(* convert Db.Types.date to Unix.tm *)
let _, udate = Unix.mktime
{ Unix.tm_sec = 0;
Unix.tm_min = 0;
Unix.tm_hour = 0;
Unix.tm_mday = (Date.access date).mday;
Unix.tm_mon = (Date.access date).month - 1;
Unix.tm_year = (Date.access date).year - 1900;
Unix.tm_wday = 0;
Unix.tm_yday = 0;
Unix.tm_isdst = false;
} in
udate
;;
let enc_weekday_en date_str =
(* for <ui:encode enc="weekday-en">: output is the weekday name *)
let date = Date.from_string date_str in
let weekday = (tm_of_date date).Unix.tm_wday in
[| "Sunday";
"Monday";
"Tuesday";
"Wednesday";
"Thursday";
"Friday";
"Saturday";
|].(weekday);
;;
let enc_month date_str =
(* for <ui:encode enc="month-en">: output is the month number (1-12) *)
let date = Date.from_string date_str in
string_of_int ((Date.access date).month)
;;
let enc_month_en date_str =
(* for <ui:encode enc="month-en">: output is the month name *)
let date = Date.from_string date_str in
let month = (Date.access date).month - 1 in
[| "January"; "February"; "March"; "April"; "May"; "June";
"July"; "August"; "September"; "October"; "November"; "December"
|].(month);
;;
(* Now follows a more complicated function that performs some date
* computation. Input is the start date, usually the first day of a
* month, and an integer from 0 to 36, the position. Imagine you
* have a calendar sheet for a month, e.g.
*
* October 2002
* Su Mo Tu We Th Fr Sa
* 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
*
* The position counts the day positions of the sheet. The sunday in the
* first row is position 0, the monday in the sixth row is position 36.
* The result of the function is either "", meaning that the position
* is empty, or a number > 0 denoting the day to display.
*
* The input string contains the date and the position, separated by
* a single space. The output string is the decimal representation of
* the day, or "".
*)
let enc_cal_day date_pos_str =
try
let k = String.index date_pos_str ' ' in
let date = Date.from_string (String.sub date_pos_str 0 k) in
let pos = int_of_string
(String.sub
date_pos_str (k+1) (String.length date_pos_str - k - 1)) in
let weekday = (tm_of_date date).Unix.tm_wday in (* 0 to 6 *)
let days = Date.days_of_month date in
let first_pos = weekday in (* first filled position *)
let last_pos = first_pos + days - 1 in (* last filled position *)
if pos >= first_pos && pos <= last_pos then
string_of_int (pos - first_pos + 1)
else
""
with
Not_found -> "??"
;;
(**********************************************************************)
(* Database *)
(**********************************************************************)
(* [db] is an unbound database handle. Later it will be bound to a certain
* database, but the connection will remain closed until the first real
* db access happens, i.e. the connection is established lazily. The
* advantage of this approach that it is compatible with the JSERV
* mode where new processes are started, and it must be ensured that the
* database connection is opened for each process individually.
*)
let db = Db.Connection.create()
;;
let rollback() =
if Db.Connection.is_connected db then
Db.Connection.rollback db
;;
(**********************************************************************)
(* Fatal errors *)
(**********************************************************************)
(* Note: Don't forget to rollback the DB transaction !!! *)
let log_error_stderr error =
Printf.eprintf "[%s] [error] [wtimer application] %s\n"
(Netdate.format "%c" (Netdate.create ~zone:Netdate.localzone (Unix.time())))
error;
flush stderr
;;
let log_error_syslog error =
let _ =
Sys.command ("logger -p user.err -t wtimer " ^
Filename.quote ("[instance " ^ Const.wtimer_dir ^ "] ") ^
Filename.quote error) in
()
;;
let log_error =
log_error_syslog (* or log_error_stderr *)
;;
let simple_error_page (ch : Netchannels.out_obj_channel) error =
log_error (Printexc.to_string error);
let out = ch # output_string in
out "<html><body><h1>Internal Error</h1>\n";
out "The application wtimer cannot serve your request. The ";
out "exact reason can be found in the error log. Please inform ";
out "your administrator about this incidence.\n";
out "</body></html>\n";
rollback()
;;
let extended_error_page (universe : universe_type) ch error =
log_error (Printexc.to_string error);
(* Instantiate the template "fatal-error" of the startpage manually. *)
(* Step 1: Create our own faked cgi_activation object *)
let cgi_env = new Netcgi_env.custom_environment () in
let dummy = new Netchannels.output_null () in
cgi_env # set_output_ch dummy;
cgi_env # set_cgi ~gateway_interface:"FAKE CGI" ~request_method:"GET" ();
cgi_env # set_input_state `Received_header;
cgi_env # set_output_state `Start;
let cgi =
new Netcgi.std_activation ~env:(cgi_env :> Netcgi_env.cgi_environment) () in
(* Step 2: Get the startpage object *)
let environment = Wd_cycle.make_environment cgi in
let startpage = universe # create environment "startpage" in
(* Step 3: Initialize the startpage object *)
let errid = Definitions.errid_of_error error in
startpage # set_variable "runtime-error" (String_value errid);
let session = !Registry.new_session universe environment in
startpage # set_variable "session" (Dialog_value (Some session));
(* Step 4: Output the template "fatal-error" *)
let inst = Wd_template.apply_byname startpage "fatal-error" [] in
let s = Wd_template.to_string startpage inst in
ch # output_string s;
rollback()
;;
(* [print_error] is called to output fatal errors. It is initialized with
* a very simple definition which is replaced later by a more
* sophisticated one.
*)
let print_error = ref simple_error_page
;;
(**********************************************************************)
(* Register dialogs etc. *)
(**********************************************************************)
let reg config universe =
(* Get the parameters to connect to the database: *)
let db_name = Get_config.option config "database-name" in
let user_name = Get_config.option config "database-user" in
let passwd = Get_config.option config "database-passwd" in
(* Bind to the database: *)
Db.Connection.bind ~db_name ~user_name ~passwd db;
(* Register output encodings: *)
universe # application # add_output_encoding "weekday-en" enc_weekday_en;
universe # application # add_output_encoding "month-en" enc_month_en;
universe # application # add_output_encoding "month" enc_month;
universe # application # add_output_encoding "mday-en" enc_mday_en;
universe # application # add_output_encoding "mday" enc_mday;
universe # application # add_output_encoding "year" enc_year;
universe # application # add_output_encoding "cal-day" enc_cal_day;
(* Register dialogs: *)
universe # register "startpage" (new Startpage.startpage db);
universe # register "editor" (new Editor.editor db);
universe # register "timetravel" (new Timetravel.timetravel db);
universe # register "session" (new Session.session);
universe # register "selectuser" (new Selectuser.selectuser db);
universe # register "export" (new Export.export db);
universe # register "admin" (new Admin.admin db);
universe # register "admin-password" (new Admin_password.admin_password db);
universe # register "admin-accounts"
(new Admin_accounts.admin_accounts config db);
universe # register "admin-access" (new Admin_access.admin_access db);
print_error := (extended_error_page universe)
;;
(* ======================================================================
* History:
*
* $Log: init.ml,v $
* Revision 1.5 2003/03/23 11:59:14 gerd
* GPL
*
* Revision 1.4 2003/02/03 01:28:59 gerd
* Continued.
*
* Revision 1.3 2003/01/28 01:07:00 gerd
* Continued.
*
* Revision 1.2 2003/01/27 22:14:39 gerd
* Initial revision.
*
*
*)
