(* * <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,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 open Printf exception Syntax_error let quote_re = Netstring_pcre.regexp "\"";; 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() | [ "csv" ] -> self # generate_csv() | [ "xml" ] -> self # generate_xml ~recode:true () | _ -> "<invalid>" 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" | [ "csv" ] -> self # generate_csv(), "text/comma-separated-values", "wtimer.csv" | [ "xml" ] -> self # generate_xml(), "text/xml", "wtimer.xml" | _ -> "<invalid>", "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() = 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 prj_sum = ref (Interval.from_string "0:0") in let sum = ref (Interval.from_string "0:0") in let print_sum() = bprintf buf " - SUM - %9s\r\n\r\n" (Interval.to_string !prj_sum) in List.iter (fun entry -> if !empty then bprintf buf "PROJECT DATE START END DELTA DESCRIPTION\r\n\r\n"; if Some entry.e_project <> !last && !last <> None then ( print_sum(); prj_sum := Interval.from_string "0:0" ); bprintf buf "%-10s %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) (Date.to_string entry.e_day ^ ":") (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; Interval.to_string t | None -> "") entry.e_description; last := Some entry.e_project; empty := false; ) sorted_entries; if !empty then bprintf buf "Nothing found.\r\n" else ( print_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 ;; (* ====================================================================== * History: * * $Log: export.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/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 * * *)