(*
* <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 23 2015-01-14 16:24:21Z gerd $
* ----------------------------------------------------------------------
*
*)
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 -> "??"
;;
(**********************************************************************)
(* New variable functions *)
(**********************************************************************)
let split_re = Pcre.regexp "[ \t\r\n]+";;
let split s = Netstring_pcre.split split_re s;;
let size_words dlg args =
(* Returns the number of words of arg0 *)
match args with
[arg1] ->
( match arg1 with
String_value s ->
String_value(string_of_int(List.length(split s)))
| _ ->
failwith "size_words: argument has wrong type"
)
| _ ->
failwith "size_words: bad number of arguments"
;;
let equal_yesno dlg args =
(* Function returns whether all arguments are the same string.
* Returns "yes" for truth, "no" otherwise.
*)
let v = ref None in
let r = ref true in
List.iter
(fun arg ->
match arg with
String_value s ->
( match !v with
None -> v := Some s
| Some u ->
r := !r && (u = s)
)
| _ ->
failwith "equal_yesno: arguments must have string type"
)
args;
if !r then
String_value "yes"
else
String_value "no"
;;
let not_yesno dlg args =
(* Negates the single string argument: "yes" becomes "no"; all other
* become "yes"
*)
match args with
[arg1] ->
( match arg1 with
String_value "yes" ->
String_value "no"
| String_value _ ->
String_value "yes"
| _ ->
failwith "not_yesno: argument has wrong type"
)
| _ ->
failwith "not_yesno: bad number of arguments"
;;
(**********************************************************************)
(* 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 config = Netcgi.default_config in
let properties =
[ "GATEWAY_INTERFACE", "FAKE CGI";
"REQUEST_METHOD", "GET";
] in
let input_header = [] in
let dummy = new Netchannels.output_null () in
let cgi_env =
new Netcgi_common.cgi_environment
~config ~properties ~input_header dummy in
let cgi =
new Netcgi_common.cgi
(cgi_env :> Netcgi.cgi_environment)
(`Direct "")
`GET
[] 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 functions: *)
universe # application # add_var_function "size_words" size_words;
universe # application # add_var_function "equal_yesno" equal_yesno;
universe # application # add_var_function "not_yesno" not_yesno;
(* 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)
;;
let run (cgi : Netcgi.cgi) =
(* If there is no path, redirect to ./start *)
if cgi # environment # cgi_path_info = "" then (
let u = cgi # url() in
cgi # set_redirection_header (u ^ "/start");
cgi # out_channel # commit_work()
)
else
let config = Get_config.parse() in
Wd_run.create_request_handler
~uifile:(Filename.concat Const.ui_dir "wtimer.ui")
~charset:Const.internal_charset
~session_manager:(new Db.Session.db_session_manager db)
~error_page:(fun ch err -> !print_error ch err)
~reg:(reg config)
()
cgi
