(*
* <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: export.ml 23 2015-01-14 16:24:21Z gerd $
* ----------------------------------------------------------------------
*
*)
open Wd_dialog
open Wd_run_cgi
open Wd_types
open Db_types.Types
open Db_types
open Db.Types
open Definitions
open Printf
exception Syntax_error
let quote_re = Netstring_pcre.regexp "\"";;
let same_year d1 d2 =
(Date.access d1).year = (Date.access d2).year
let same_month d1 d2 =
same_year d1 d2 &&
(Date.access d1).month = (Date.access d2).month
let same_day d1 d2 =
Date.cmp d1 d2 = 0
let same_week d1 d2 =
let (wn1,wy1) = Date.iso8601_week_pair d1 in
let (wn2,wy2) = Date.iso8601_week_pair d2 in
wy1 = wy2 && wn1 = wn2
let days =
[| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
let week_day d =
let wd = Date.week_day d in
days.(wd)
class export db universe name env =
object (self)
inherit dialog universe name env
inherit error_behaviour
val mutable start_date = Date.from_string "1970-01-01"
val mutable end_date = Date.from_string "1970-01-01"
method private check_auth () =
check_auth db (self # dialog_variable "session")
method private parse_dates() =
let errors = ref false in
( try
start_date <- Date.from_string (self # string_variable "start-date")
with
Failure _
| Bad_date ->
errors := true;
self # add_message "error-bad-start"
);
( try
end_date <- Date.from_string (self # string_variable "end-date")
with
Failure _
| Bad_date ->
errors := true;
self # add_message "error-bad-end"
);
if not !errors then (
if Date.cmp end_date start_date < 0 then (
errors := true;
self # add_message "error-end-before-start"
)
);
if !errors then raise Syntax_error;
()
method private preview() =
match self # enum_variable "format" with
[ "ascii-chrono" ] ->
self # generate_ascii_chrono()
| [ "ascii-project" ] ->
self # generate_ascii_project()
| [ "ascii-project-ext" ] ->
self # generate_ascii_project
~daily_total:true ~weekly_total:true ~monthly_total:true ()
| [ "csv" ] ->
self # generate_csv()
| [ "xml" ] ->
self # generate_xml ~recode:true ()
| fmt ->
sprintf "<invalid: %s>" (String.concat "," fmt)
method private download() =
(* returns triple (contents, content_type, filename) *)
(* Note: Because we want that the browser asks the user to save the file,
* we do not send the real content types, but always
* "application/octet-stream". This is not correct, because our intention
* is already indicated by the "Content-dispositon" header, and RFC-
* conforming browsers should respect that. However, exisiting browsers
* behave differently, and we have to take this into account.
*)
match self # enum_variable "format" with
[ "ascii-chrono" ] ->
self # generate_ascii_chrono(), "text/english", "wtimer.txt"
| [ "ascii-project" ] ->
self # generate_ascii_project(), "text/english", "wtimer.txt"
| [ "ascii-project-ext" ] ->
self # generate_ascii_project
~daily_total:true ~weekly_total:true ~monthly_total:true (),
"text/english", "wtimer.txt"
| [ "csv" ] ->
self # generate_csv(), "text/comma-separated-values", "wtimer.csv"
| [ "xml" ] ->
self # generate_xml(), "text/xml", "wtimer.xml"
| fmt ->
sprintf "<invalid: %s>" (String.concat "," fmt),
"application/octet-stream", "wtimer.any"
method private generate_ascii_chrono() =
let login = User(self # string_variable "session.login-user") in
let inst = Instance(self # string_variable "session.current-sheet") in
let dates = Db_ac.Entry.list db login inst start_date end_date in
let buf = Buffer.create 1024 in
bprintf buf "SHEET: %s\r\n" (self # string_variable "session.current-sheet");
bprintf buf "FROM: %s\r\n" (Date.to_string start_date);
bprintf buf "UNTIL: %s\r\n\r\n" (Date.to_string end_date);
let empty = ref true in
let sum = ref (Interval.from_string "0:0") in
List.iter
(fun date ->
if !empty then
bprintf buf
"DATE START END DELTA PROJECT DESCRIPTION\r\n\r\n";
let day = Db_ac.Entry.get db login inst date in
let is_first = ref true in
List.iter
(fun entry ->
bprintf
buf "%11s %5s - %5s %5s %-10s %s\r\n"
(if !is_first then Date.to_string date ^ ":" else "")
(match entry.e_start with
Some t -> Time.to_string t
| None -> "")
(match entry.e_end with
Some t -> Time.to_string t
| None -> "")
(match entry.e_duration with
Some t -> sum := Interval.add !sum t;
Interval.to_string t
| None -> "")
entry.e_project
entry.e_description;
is_first := false;
)
day.d_entries;
empty := false;
)
dates;
if !empty then
bprintf buf "Nothing found.\r\n"
else
bprintf buf "%11s %9s\r\n"
"- SUM -"
(Interval.to_string !sum);
Buffer.contents buf
method private generate_ascii_project
?(daily_total=false) ?(weekly_total=false)
?(monthly_total=false) () =
let login = User(self # string_variable "session.login-user") in
let inst = Instance(self # string_variable "session.current-sheet") in
let dates = Db_ac.Entry.list db login inst start_date end_date in
let days = List.map (Db_ac.Entry.get db login inst) dates in
let entries = List.flatten (List.map (fun day -> day.d_entries) days) in
let buf = Buffer.create 1024 in
bprintf buf "SHEET: %s\r\n" (self # string_variable "session.current-sheet");
bprintf buf "FROM: %s\r\n" (Date.to_string start_date);
bprintf buf "UNTIL: %s\r\n\r\n" (Date.to_string end_date);
let sorted_entries =
List.sort
(fun a b ->
let n_project = compare a.e_project b.e_project in
if n_project <> 0 then
n_project
else
let n_day = Date.cmp a.e_day b.e_day in
if n_day <> 0 then
n_day
else
let n_index = compare a.e_index b.e_index in
n_index
)
entries
in
let empty = ref true in
let last = ref None in
let last_date = ref (Date.from_string "0000-01-01") in
let prj_sum = ref (Interval.from_string "0:0") in
let dy_sum = ref (Interval.from_string "0:0") in
let wk_sum = ref (Interval.from_string "0:0") in
let mo_sum = ref (Interval.from_string "0:0") in
let sum = ref (Interval.from_string "0:0") in
let print_prj_sum() =
bprintf buf
" - PROJECT TOTAL - %9s\r\n\r\n"
(Interval.to_string !prj_sum);
bprintf buf
"===========================================================\r\n\r\n" in
let print_dy_sum() =
bprintf buf
" DAY %9s\r\n\r\n"
(Interval.to_string !dy_sum) in
let print_wk_sum() =
bprintf buf
" WEEK %9s\r\n\r\n"
(Interval.to_string !wk_sum);
bprintf buf
" ------------------------------------------------\r\n\r\n" in
let print_mo_sum() =
bprintf buf
" MONTH %9s\r\n\r\n"
(Interval.to_string !mo_sum);
bprintf buf
" ================================================\r\n\r\n" in
List.iter
(fun entry ->
if !empty then
bprintf buf
"PROJECT DATE START END DELTA DESCRIPTION\r\n\r\n";
let new_day =
!last <> None && not(same_day entry.e_day !last_date) in
let new_week =
new_day && not(same_week entry.e_day !last_date) in
let new_month =
new_day && not(same_month entry.e_day !last_date) in
let start_day =
!last=None || new_day in
if new_day && daily_total then (
print_dy_sum();
dy_sum := Interval.from_string "0:0"
);
if new_week && weekly_total then (
print_wk_sum();
wk_sum := Interval.from_string "0:0"
);
if new_month && monthly_total then (
print_mo_sum();
mo_sum := Interval.from_string "0:0"
);
if Some entry.e_project <> !last && !last <> None then (
print_prj_sum();
prj_sum := Interval.from_string "0:0"
);
bprintf buf "%-10s %3s %11s %5s - %5s %5s %s\r\n"
(if Some entry.e_project = !last then "" else
if entry.e_project = "" then "(empty)" else
entry.e_project)
(if start_day then week_day entry.e_day else "")
(if start_day then Date.to_string entry.e_day ^ ":" else "")
(match entry.e_start with
Some t -> Time.to_string t
| None -> "")
(match entry.e_end with
Some t -> Time.to_string t
| None -> "")
(match entry.e_duration with
Some t -> prj_sum := Interval.add !prj_sum t;
sum := Interval.add !sum t;
dy_sum := Interval.add !dy_sum t;
wk_sum := Interval.add !wk_sum t;
mo_sum := Interval.add !mo_sum t;
Interval.to_string t
| None -> "")
entry.e_description;
last := Some entry.e_project;
last_date := entry.e_day;
empty := false;
)
sorted_entries;
if !empty then
bprintf buf "Nothing found.\r\n"
else (
if daily_total then print_dy_sum();
if weekly_total then print_wk_sum();
if monthly_total then print_mo_sum();
print_prj_sum();
bprintf buf "- TOTAL - %9s\r\n"
(Interval.to_string !sum);
);
Buffer.contents buf
method private generate_csv() =
let login = User(self # string_variable "session.login-user") in
let inst = Instance(self # string_variable "session.current-sheet") in
let dates = Db_ac.Entry.list db login inst start_date end_date in
let sheet = self # string_variable "session.current-sheet" in
let buf = Buffer.create 1024 in
let at_new_line = ref true in
let add_field v =
if not !at_new_line then Buffer.add_char buf ',';
let v' = Netstring_pcre.global_replace quote_re "\"\"" v in
Buffer.add_char buf '"';
Buffer.add_string buf v';
Buffer.add_char buf '"';
at_new_line := false
in
let new_line() =
Buffer.add_string buf "\r\n";
at_new_line := true
in
add_field "sheet";
add_field "date";
add_field "start_time";
add_field "end_time";
add_field "duration";
add_field "project";
add_field "description";
new_line();
List.iter
(fun date ->
let day = Db_ac.Entry.get db login inst date in
List.iter
(fun entry ->
add_field sheet;
add_field (Date.to_string date);
add_field (match entry.e_start with
Some t -> Time.to_string t
| None -> "");
add_field (match entry.e_end with
Some t -> Time.to_string t
| None -> "");
add_field (match entry.e_duration with
Some t -> Interval.to_string t
| None -> "");
add_field entry.e_project;
add_field entry.e_description;
new_line();
)
day.d_entries;
)
dates;
Buffer.contents buf
method private generate_xml ?(recode = false) () =
let login = User(self # string_variable "session.login-user") in
let inst = Instance(self # string_variable "session.current-sheet") in
(* Do access control manually, because Db_xml does not support that: *)
if not (Db.Permission.check db inst login `Read) then
raise Db_ac.Types.Permission_denied;
(* Call Db_xml to generate the XML document: *)
let buf = Buffer.create 1024 in
if recode then begin
let out = new Netchannels.output_buffer buf in
let encoder = new Netconversion.recoding_pipe ~in_enc:`Enc_utf8
~out_enc:Const.internal_charset () in
let filter = new Netchannels.output_filter encoder out in
Db_xml.export_instances ~instances:[inst] ~start_date ~end_date db filter;
filter # close_out();
out # close_out();
end
else begin
let out = new Netchannels.output_buffer buf in
Db_xml.export_instances ~instances:[inst] ~start_date ~end_date db out;
out # close_out();
end;
Buffer.contents buf
method private add_message m =
let msgs = self # enum_variable "message" in
self # set_variable "message" (Enum_value(m :: msgs));
method private try_prepare_page() = ()
method private try_handle() =
(* Before anything else happens, parse the input boxes: *)
( try
self # set_variable "message" (Enum_value []);
self # parse_dates()
with
Syntax_error ->
(* "message" already set! *)
raise(Change_page self#page_name);
);
try
(* Check whether a file menu button has been pressed: *)
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 "export-preview" ->
let s = self # preview() in
self # set_variable "data" (String_value s)
| Button "export-download" ->
let s, content_type, filename = self # download() in
self # set_variable "data" (String_value s);
let rh = (self # environment).response_header in
rh.rh_content_type <- (* content_type *)
"application/octet-stream";
rh.rh_filename <- Some filename;
()
| Button "cont-error" ->
self # set_next_page "export"
| _ ->
()
)
end
;;
Registry.new_export :=
fun universe env opt_session ->
let dlg = universe # create env "export" in
dlg # set_variable "session" (Dialog_value opt_session);
match opt_session with
Some session ->
let date_str = session # string_variable "current-date" in
let date = Date.from_string date_str in
let date_rec = Date.access date in
let dom = Date.days_of_month date in
let date' = Date.create { date_rec with mday = dom } in
let date'_str = Date.to_string date' in
dlg # set_variable "start-date" (String_value date_str);
dlg # set_variable "end-date" (String_value date'_str);
dlg
| None ->
assert false
;;
