(*
* <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: editor.ml,v 1.5 2003/03/23 11:59:14 gerd Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_dialog
open Wd_run_cgi
open Wd_types
open Db_types.Types
open Db_types
open Db.Types
open Definitions
exception Syntax_error ;;
(* Indicates ill-formed form fields *)
exception Force_dialog of dialog_type ;;
(* Like Change_dialog, but bypasses the check on unsaved changes *)
type row_id = [ `Db_id of int | `Virtual_id of int ]
;;
type row = { r_id : row_id;
r_day : date;
r_start : time option;
r_end : time option;
r_duration : interval option;
r_project : string;
r_description : string;
}
;;
(* Rows are like entries (Db.Types.entry), but:
* - Rows can have virtual IDs. These IDs are used for newly created
* rows until they are saved for the first time. The virtual IDs
* have the string representation "_<ID>", i.e. there is an underscore
* before the ID's decimal representation.
* - Rows are ordered by appearance in row lists, whereas entries of the
* same day are ordered by the index.
*)
let date_list month =
(* Creates a list of all dates of [month] in increasing order. [month]
* is an arbitrary date of the meant month.
*)
let n_days = Date.days_of_month month in
let rec next_date n =
if n <= n_days then
let m = Date.access month in
(Date.create { m with mday = n }) :: next_date (n+1)
else
[]
in
next_date 1
;;
let map_entries f days =
List.flatten
(List.map
(fun day ->
List.map f day.d_entries
)
days
)
;;
let row_id_string row =
match row.r_id with
`Db_id id -> string_of_int id
| `Virtual_id id -> "_" ^ string_of_int id
;;
let row_id_variant id_str =
if id_str.[0] = '_' then
`Virtual_id(int_of_string("0" ^ id_str))
else
`Db_id(int_of_string id_str)
;;
let make_virtual_id rows =
let m = ref 0 in
List.iter
(fun row ->
match row.r_id with
`Virtual_id k ->
m := max !m k
| _ ->
()
)
rows;
!m + 1
;;
let make_alist_of_rows f rows =
List.map
(fun row ->
(row_id_string row, f row)
)
rows
;;
let make_str_alist_of_rows f =
make_alist_of_rows (fun x -> String_value(f x))
;;
let rec dates_occuring_in_rows rows =
match rows with
row::rows' ->
let dates' = dates_occuring_in_rows rows' in
let dates =
if List.mem row.r_day dates' then
dates'
else
row.r_day :: dates' in
dates
| [] ->
[]
;;
let rec last_date_in_rows month rows =
match rows with
[] -> month
| [row] -> row.r_day
| row :: rows' -> last_date_in_rows month rows'
;;
let rec projects_occuring_in_rows rows =
match rows with
row::rows' ->
let prj' = projects_occuring_in_rows rows' in
let prj =
if List.mem row.r_project prj' then
prj'
else
if row.r_project = "" then
prj'
else
row.r_project :: prj' in
prj
| [] ->
[]
;;
let rec insert_before f rows row_id =
match rows with
row::rows' ->
if row.r_id = row_id then
let new_rows = f row.r_day in
new_rows @ rows
else
row::(insert_before f rows' row_id)
| [] ->
assert false
;;
let rec append_after f rows date =
match rows with
row::rows' ->
if Date.cmp row.r_day date > 0 then
let new_rows = f date in
new_rows @ rows
else
row::(append_after f rows' date)
| [] ->
let new_rows = f date in
new_rows
;;
let day_re = Netstring_pcre.regexp "^day-(.*)$";;
let iter_selection ~select_row ~select_day sel_alist =
List.iter
(fun (id_str, sel) ->
if sel = Enum_value [ "yes" ] then begin
match Netstring_pcre.string_match day_re id_str 0 with
Some m ->
(* Format "day-YYYY-MM-DD" *)
let date_str = Netstring_pcre.matched_group m 1 id_str in
select_day (Date.from_string date_str)
| None ->
(* An ID *)
let row_id = row_id_variant id_str in
select_row row_id
end
)
sel_alist
;;
let rec multiply_list n f arg =
if n <= 0 then
[]
else
(f arg) @ (multiply_list (n-1) f arg)
;;
let to_cb_str (rows : row list) : string =
Marshal.to_string rows []
;;
let from_cb_str (str : string) : row list =
Marshal.from_string str 0
;;
class editor db universe name env =
object (self)
inherit dialog universe name env
inherit error_behaviour
val mutable rows = [] (* see read_rows, write_rows *)
val mutable ins_number = 1
val mutable errors = []
method private check_auth () =
check_auth db (self # dialog_variable "session")
method private load_month() =
(* Loads the month indicated by session.current-data of the sheet
* session.current-sheet, and stores it into the dialog variables.
*)
let login = User (self # string_variable "session.login-user") in
let sheet = Instance (self # string_variable "session.current-sheet") in
let date = self # string_variable "session.current-date" in
let dates = date_list (Date.from_string date) in
let days = List.map (Db_ac.Entry.get db login sheet) dates in
(* load from db *)
let entries = map_entries (fun e -> e) days in
let sorted_entries =
List.sort
(fun e1 e2 ->
let x = Date.cmp e1.e_day e2.e_day in
if x = 0 then
Pervasives.compare e1.e_index e2.e_index
else
x)
entries in
let sorted_rows =
List.map
(fun entry ->
{ r_id = `Db_id (match entry.e_id with
Some id -> id
| None -> assert false);
r_day = entry.e_day;
r_start = entry.e_start;
r_end = entry.e_end;
r_duration = entry.e_duration;
r_project = entry.e_project;
r_description = entry.e_description;
}
)
sorted_entries in
rows <- sorted_rows;
self # set_variable "checksum" (String_value (self # checksum()));
self # set_variable "read-only"
(String_value
(if Db.Permission.check db sheet login `Write then "no" else "yes"));
self # write_rows ();
method private checksum () =
(* Returns the checksum of [rows] *)
let v = self # dump_rows() in
Digest.to_hex (Digest.string v)
(* Note: My first attempt was to use the digest of Marshal.to_string
* as checksum. This did not work, I do not know why.
*)
method private is_modified =
(* Return whether there are unsaved modifications of data *)
let db_checksum = self # string_variable "checksum" in
let cur_checksum = self # checksum() in
db_checksum <> cur_checksum
method private dump_rows () =
(* Creates a string representation of rows *)
let buffer = Buffer.create 1000 in
List.iter
(fun row ->
Printf.bprintf
buffer
"id=%s day=%s start=%s end=%s dur=%s project=\"%s\" descr=\"%s\"\n"
(match row.r_id with
`Db_id n -> "db_" ^ string_of_int n
| `Virtual_id n -> "vt_" ^ string_of_int n
)
(Date.to_string row.r_day)
(match row.r_start with
None -> "-"
| Some x -> Time.to_string x
)
(match row.r_end with
None -> "-"
| Some x -> Time.to_string x
)
(match row.r_duration with
None -> "-"
| Some x -> Interval.to_string x
)
(String.escaped row.r_project)
(String.escaped row.r_description)
)
rows;
Buffer.contents buffer
method private read_rows () =
(* Read the dialog variables and store contents as [row list] in the
* instance variable [rows]. When there are errors, [rows] remains empty,
* and the [errors] variable is filled instead, and the exception
* [Syntax_error] is raised.
*)
let errlist = ref [] in
let catch_errors prefix id_str f arg =
try
f arg
with
Bad_date | Bad_time | Bad_interval | Failure _ ->
errlist := (prefix ^ id_str, "yes") :: !errlist;
None
in
let lookup = self # lookup_string_variable in (* abbr *)
let found_rows =
List.map
(fun (id_str, date_str) ->
let date =
match date_str with
String_value s -> s
| _ -> assert false in
let row =
{ r_id = row_id_variant id_str;
r_day = Date.from_string date;
r_start = catch_errors "from-" id_str
(fun x ->
if x = "" then None
else Some(Time.from_string x) )
(lookup "time-from" id_str);
r_end = catch_errors "to-" id_str
(fun x ->
if x = "" then None
else Some(Time.from_string x) )
(lookup "time-to" id_str);
r_duration = catch_errors "duration-" id_str
(fun x ->
if x = "" then None
else Some(Interval.from_string x) )
(lookup "duration" id_str);
r_project = lookup "project" id_str;
r_description = lookup "description" id_str;
} in
match (row.r_start, row.r_end, row.r_duration) with
(Some rst), (Some rend), _ ->
{ row with
r_duration = Some(Interval.distance rend rst)
}
| _ -> row
)
(self # alist_variable "date")
in
( try
ins_number <- int_of_string (self # string_variable "ins-number")
with
Failure _ ->
errlist := ("ins-number", "") :: !errlist
);
if !errlist = [] then (
rows <- found_rows;
errors <- [];
) else (
rows <- [];
errors <- !errlist;
raise Syntax_error
)
method private write_rows () =
(* Set the dialog variables to the contents of [rows], a [row list] *)
let month = self # string_variable "session.current-date" in
let all_dates = date_list (Date.from_string month) in
self # set_variable "grouped-by-days"
(Alist_value
(List.map
(fun date ->
let rows_for_date =
List.find_all (fun r -> r.r_day = date) rows in
(* already in the right order! *)
let s =
String.concat " " (List.map row_id_string rows_for_date) in
(Date.to_string date, String_value s)
)
all_dates)
);
let prj_list = projects_occuring_in_rows rows in
self # set_variable "grouped-by-projects"
(Alist_value
(List.map
(fun prj ->
let rows_for_prj =
List.find_all (fun r -> r.r_project = prj) rows in
(* already in the right order! *)
let s =
String.concat " " (List.map row_id_string rows_for_prj) in
(prj, String_value s)
)
prj_list)
);
self # set_variable "available-projects"
(Dyn_enum_value (List.map (fun prj -> (prj,prj)) prj_list));
self # set_variable "date"
(Alist_value
(make_str_alist_of_rows (fun r -> Date.to_string r.r_day) rows));
self # set_variable "time-from"
(Alist_value
(make_str_alist_of_rows (fun r ->
match r.r_start with
Some t -> Time.to_string t
| None -> "") rows));
self # set_variable "time-to"
(Alist_value
(make_str_alist_of_rows (fun r ->
match r.r_end with
Some t -> Time.to_string t
| None -> "") rows));
self # set_variable "duration"
(Alist_value
(make_str_alist_of_rows (fun r ->
match r.r_duration with
Some i -> Interval.to_string i
| None -> "") rows @
List.map
(fun prj ->
let rows_for_prj =
List.find_all (fun r -> r.r_project = prj) rows in
("project-" ^ prj,
String_value
(Interval.to_string
(List.fold_left
(fun sum row ->
match row.r_duration with
None -> sum
| Some d -> Interval.add sum d)
(Interval.from_string "00:00")
rows_for_prj
))
)
)
prj_list
)
);
self # set_variable "project"
(Alist_value
(make_str_alist_of_rows (fun r -> r.r_project) rows));
self # set_variable "description"
(Alist_value
(make_str_alist_of_rows (fun r -> r.r_description) rows));
self # set_variable "selection"
(Alist_value
(make_alist_of_rows (fun _ -> Enum_value [ "no" ]) rows @
List.map (fun date ->
("day-" ^ Date.to_string date),
Enum_value [ "no" ]) all_dates
)
);
self # set_variable "modified"
(String_value (if self # is_modified then "yes" else "no"));
()
method private insert () =
let id = ref (make_virtual_id rows) in
let something_found = ref false in
let make_row date =
let r_id = !id in
incr id;
something_found := true;
[ { r_id = `Virtual_id r_id;
r_day = date;
r_start = None;
r_end = None;
r_duration = None;
r_project = "";
r_description = "";
}
]
in
let make_rows date = multiply_list ins_number make_row date in
let do_insert_before row_id =
rows <- insert_before make_rows rows row_id in
let do_append_after date =
rows <- append_after make_rows rows date in
iter_selection
~select_row:do_insert_before
~select_day:do_append_after
(self # alist_variable "selection");
if not !something_found then
let date =
Date.from_string(self # string_variable "session.current-date") in
do_append_after (last_date_in_rows date rows)
method private paste () =
let id = ref (make_virtual_id rows) in
let clipboard_str = self # string_variable "session.clipboard" in
if clipboard_str <> "" then begin
let clipboard = from_cb_str clipboard_str in
let make_rows date =
List.map
(fun row ->
let r_id = !id in
incr id;
{ row with
r_id = `Virtual_id r_id;
r_day = date;
}
)
clipboard
in
let do_insert_before row_id =
rows <- insert_before make_rows rows row_id in
let do_append_after date =
rows <- append_after make_rows rows date in
iter_selection
~select_row:do_insert_before
~select_day:do_append_after
(self # alist_variable "selection");
end
method private delete () =
let something_found = ref false in
let do_delete row_id =
something_found := true;
rows <- List.filter (fun row -> row.r_id <> row_id) rows in
iter_selection
~select_row:do_delete
~select_day:(fun _ -> ())
(self # alist_variable "selection");
if not !something_found then
self # add_message "error-missing-selection"
method private copy_to_clipboard ?(cut = false) () =
let something_found = ref false in
let clipboard = ref [] in
let do_copy row_id =
something_found := true;
clipboard := !clipboard @ List.filter (fun row -> row.r_id = row_id) rows
in
iter_selection
~select_row:do_copy
~select_day:(fun _ -> ())
(self # alist_variable "selection");
if not !something_found then
self # add_message "error-missing-selection"
else (
self # set_variable "session.clipboard"
(String_value (to_cb_str !clipboard));
if cut then self # delete()
)
method private save () =
let sheet = Instance (self # string_variable "session.current-sheet") in
let dates = dates_occuring_in_rows rows in
let days =
List.map
(fun date ->
let rows_for_date =
List.find_all (fun r -> r.r_day = date) rows in
let k = ref 0 in
let entries =
List.map
(fun row ->
let index = !k in
incr k;
{ e_id = ( match row.r_id with
`Db_id id -> Some id
| `Virtual_id _ -> None
);
e_instance = sheet;
e_day = date;
e_index = index;
e_start = row.r_start;
e_end = row.r_end;
e_duration = row.r_duration;
e_project = row.r_project;
e_description = row.r_description;
}
)
rows_for_date in
{ d_instance = sheet;
d_day = date;
d_entries = entries;
}
)
dates in
let login = User (self # string_variable "session.login-user") in
List.iter (Db_ac.Entry.update db login) days; (* store in db *)
Db.Connection.commit db;
self # set_variable "checksum" (String_value (self # checksum()));
self # add_message "saved";
method private time_prev () =
let date =
Date.from_string(self # string_variable "session.current-date") in
let month = (Date.access date).month in
let year = (Date.access date).year in
if year = 1902 && month = 1 then
self # add_message "error-invalid-date"
else
let date' =
Date.create { year = if month = 1 then year - 1 else year;
month = if month = 1 then 12 else month - 1;
mday = 1
} in
self # move_to date'
method private time_next () =
let date =
Date.from_string(self # string_variable "session.current-date") in
let month = (Date.access date).month in
let year = (Date.access date).year in
if year = 2037 && month = 12 then
self # add_message "error-invalid-date"
else
let date' =
Date.create { year = if month = 12 then year + 1 else year;
month = if month = 12 then 1 else month + 1;
mday = 1
} in
self # move_to date'
method private move_to new_date =
let session =
match self # dialog_variable "session" with
None -> assert false
| Some s -> s
in
let session' = session # copy in
session' # set_variable "current-date"
(String_value(Date.to_string new_date));
raise(Change_dialog(!Registry.new_editor universe env (Some session')))
method private activate_deferred_dialog ?(force = false) () =
match self # dialog_variable "deferred-dialog" with
None ->
assert false
| Some dlg ->
self # set_variable "deferred-dialog" (Dialog_value None);
raise(if force then Force_dialog dlg else Change_dialog dlg)
method private add_message m =
let msgs = self # enum_variable "message" in
self # set_variable "message" (Enum_value(m :: msgs));
self # set_variable "scroll_position" (String_value "");
method private try_prepare_page() =
if self # string_variable "modified" = "load" then begin
self # load_month()
end
method private try_handle() =
(* Before anything else happens, parse the input boxes: *)
( try
self # set_variable "message" (Enum_value []);
self # set_variable "error-boxes" (Dyn_enum_value []);
self # read_rows(); (* may raise Syntax_error *)
with
Syntax_error ->
self # set_variable "error-boxes" (Dyn_enum_value errors);
self # add_message "error-syntax";
self # set_variable "modified" (String_value "yes");
raise(Change_page self#page_name);
);
(* Catch trials to leave this dialog, so we have the chance to
* warn the user if there are unmodified changes that would
* be lost
*)
try
(* Check whether a file menu button has been pressed: *)
try
raise(Change_dialog(Filemenu.handle (self :> dialog_type) db self#event))
with
Filemenu.Not_competent ->
(* No, it is another button: *)
( match self # event with
Button "edit-ins" ->
self # insert ()
| Button "edit-del" ->
self # delete ()
| Button "edit-copy" ->
self # copy_to_clipboard ()
| Button "edit-cut" ->
self # copy_to_clipboard ~cut:true ()
| Button "edit-paste" ->
self # paste ()
| Button "file-save" ->
self # save ()
| Button "time-prev" ->
self # time_prev ()
| Button "time-next" ->
self # time_next ();
| Button "unsaved-save" ->
self # save ();
self # activate_deferred_dialog();
| Button "unsaved-discard" ->
self # activate_deferred_dialog ~force:true ();
| Button "unsaved-cancel" ->
self # set_variable "deferred-dialog" (Dialog_value None);
raise(Change_page "timesheet-chrono")
| Button "cont-error" ->
self # set_next_page "timesheet-chrono"
| _ ->
()
);
(* Always write rows (to repair formatting details) *)
self # write_rows ()
with
Change_dialog new_dlg as change_request ->
(* The user tries to leave the dialog. Check whether there are
* unsaved changes of data.
*)
if self # is_modified then begin
self # set_variable "deferred-dialog" (Dialog_value (Some new_dlg));
raise (Change_page "unsaved")
end
else
raise change_request
| Force_dialog new_dlg ->
raise(Change_dialog new_dlg)
end
;;
Registry.new_editor :=
fun universe env opt_session ->
let dlg = universe # create env "editor" in
dlg # set_variable "session" (Dialog_value opt_session);
dlg
;;
(* ======================================================================
* History:
*
* $Log: editor.ml,v $
* Revision 1.5 2003/03/23 11:59:14 gerd
* GPL
*
* Revision 1.4 2003/02/02 23:27:31 gerd
* "duration" is now always set to the correct value
*
* Revision 1.3 2003/01/26 23:45:16 gerd
* Improved error behaviour.
*
* Revision 1.2 2003/01/16 00:39:25 gerd
* Continued.
*
* Revision 1.1 2002/11/16 12:34:51 gerd
* Initial revision
*
*
*)
