(*
* <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: db_xml.ml,v 1.3 2003/03/23 11:59:14 gerd Exp $
* ----------------------------------------------------------------------
*
*)
open Db.Connection
open Db.Types
open Db_types.Types
open Db_types
open Pxp_types
open Pxp_yacc
open Pxp_reader
open Pxp_document
let wef_namespace = "http://www.ocaml-programming.de/formal/wef-namespace" ;;
let wef_public_id = "-//ocaml-programming.de//DTD WEF 1//EN";;
let wef_system_id = "http://www.ocaml-programming.de/formal/wef-dtd-1";;
let indent = [| ""; " "; " "; " "; " "; " " |] ;;
let out_indent out level =
out # output_string (indent.(level))
;;
let unsafe_chars_xml =
"<>\"'&\r\n\t";;
let encode =
Netencoding.Html.encode
~in_enc:Const.internal_charset
~out_enc:`Enc_utf8
~prefer_name:false
~unsafe_chars:unsafe_chars_xml
()
;;
let encode_bool =
function
false -> "no"
| true -> "yes"
;;
let output_decl root_name out =
out # output_string "<?xml version='1.0' encoding='UTF-8'?>\n";
out # output_string ("<!DOCTYPE " ^ root_name ^
" PUBLIC '" ^ wef_public_id ^ "' '" ^ wef_system_id ^
"'>\n\n")
;;
let output_users ?(level = 0) ?users db out =
let user_list =
match users with
None -> Db.User.list db
| Some l -> List.map (Db.User.get db) l
in
out_indent out level;
out # output_string "<wef:users";
if level = 0 then
out # output_string (" xmlns:wef='" ^ wef_namespace ^ "'>\n")
else
out # output_string ">\n";
List.iter
(fun user ->
out_indent out (level+1);
out # output_string "<wef:user\n";
( match user.u_name with
User n ->
out_indent out (level+2);
out # output_string ("name='" ^ encode n ^ "'\n");
);
out_indent out (level+2);
out # output_string ("description='" ^ encode user.u_description ^ "'\n");
( match user.u_password with
None -> ()
| Some pw ->
out_indent out (level+2);
out # output_string ("password='" ^ encode pw ^ "'\n");
);
out_indent out (level+2);
out # output_string ("login='" ^ encode_bool user.u_login ^ "'\n");
out_indent out (level+2);
out # output_string ("admin='" ^ encode_bool user.u_admin ^ "'/>\n");
)
user_list;
out_indent out level;
out # output_string "</wef:users>\n"
;;
let very_early = Date.from_string "1900-01-01";; (* TODO *)
let very_late = Date.from_string "2100-12-31";; (* TODO *)
let output_instances ?(level = 0) ?users ?instances
?(start_date = very_early)
?(end_date = very_late) db out =
let inst_list =
match instances with
None -> Db.Instance.list db
| Some l -> List.map (Db.Instance.get db) l
in
let user_name_list =
match users with
None ->
List.map (fun user -> user.u_name) (Db.User.list db)
| Some l ->
List.iter
(fun u -> ignore(Db.User.get db u))
l; (* assert that users exist *)
l
in
out_indent out level;
out # output_string "<wef:instances";
if level = 0 then
out # output_string (" xmlns:wef='" ^ wef_namespace ^ "'>\n")
else
out # output_string ">\n";
List.iter
(fun inst ->
( match inst.i_name with
Instance n ->
out_indent out (level+1);
out # output_string ("<wef:instance\n");
out_indent out (level+2);
out # output_string ("name='" ^ encode n ^ "'\n");
out_indent out (level+2);
out # output_string ("description='" ^ encode inst.i_description
^ "'>\n");
);
let perms = Db.Permission.get db inst.i_name in
if perms.p_set <> [] then begin
out_indent out (level+2);
out # output_string "<wef:permission>\n";
List.iter
(fun (User u, p) ->
if List.mem (User u) user_name_list then begin
out_indent out (level+3);
out # output_string ("<wef:allow user='" ^
encode u ^
"' right='" ^
( match p with
`Write -> "write"
| `Read -> "read"
| `Owner -> "owner"
) ^ "'/>\n");
end
)
perms.p_set;
out_indent out (level+2);
out # output_string "</wef:permission>\n";
end;
let dates = Db.Entry.list db inst.i_name start_date end_date in
List.iter
(fun date ->
out_indent out (level+2);
out # output_string ("<wef:day date='" ^ Date.to_string date ^
"'>\n");
let day = Db.Entry.get db inst.i_name date in
List.iter
(fun entry ->
out_indent out (level+3);
out # output_string "<wef:entry\n";
( match entry.e_start with
None -> ()
| Some x ->
out_indent out (level+4);
out # output_string ("start-time='" ^
Time.to_string x ^ "'\n");
);
( match entry.e_end with
None -> ()
| Some x ->
out_indent out (level+4);
out # output_string ("end-time='" ^
Time.to_string x ^ "'\n");
);
( match entry.e_duration with
None -> ()
| Some x ->
out_indent out (level+4);
out # output_string ("duration='" ^
Interval.to_string x ^ "'\n");
);
out_indent out (level+4);
out # output_string ("project='" ^ encode entry.e_project ^
"'\n");
out_indent out (level+4);
out # output_string ("description='" ^
encode entry.e_description ^ "'/>\n");
)
day.d_entries;
out_indent out (level+2);
out # output_string "</wef:day>\n";
)
dates;
out_indent out (level+1);
out # output_string "</wef:instance>\n";
)
inst_list;
out_indent out level;
out # output_string "</wef:instances>\n"
;;
let export_users ?users db out =
output_decl "wef:users" out;
output_users ~level:0 ?users db out
;;
let export_instances ?instances ?start_date ?end_date db out =
output_decl "wef:instances" out;
output_instances ~level:0 ?instances ?start_date ?end_date db out
;;
let export_dataset ?users ?instances ?start_date ?end_date db out =
output_decl "wef:dataset" out;
out # output_string ("<wef:dataset xmlns:wef='" ^ wef_namespace ^ "'>\n");
output_users ~level:1 ?users db out;
output_instances ~level:1 ?users ?instances ?start_date ?end_date db out;
out # output_string "</wef:dataset>\n";
;;
type conflict_strategy =
[ `Fail
| `Overwrite
| `Only_add
]
;;
exception Conflict of string
;;
let import ?(onconflict = `Fail) db inp =
let rec trav_dataset node =
assert(node # node_type = T_element "wef:dataset");
node # iter_nodes trav_start
and trav_users node =
assert(node # node_type = T_element "wef:users");
node # iter_nodes trav_user
and trav_user node =
assert(node # node_type = T_element "wef:user");
let name = node # required_string_attribute "name" in
let description = node # required_string_attribute "description" in
let password = node # optional_string_attribute "password" in
let login = node # required_string_attribute "login" = "yes" in
let admin = node # required_string_attribute "admin" = "yes" in
let user = { u_name = User name;
u_description = description;
u_password = password;
u_login = login;
u_admin = admin;
} in
( try
let old_user = Db.User.get db (User name) in
(* User exists! *)
if old_user <> user then (
match onconflict with
`Fail ->
raise (Conflict("User " ^ name))
| `Overwrite ->
Db.User.update db user
| `Only_add ->
()
)
with
No_such_user _ ->
Db.User.insert db user
)
and trav_instances node =
assert(node # node_type = T_element "wef:instances");
node # iter_nodes trav_instance
and trav_instance node =
assert(node # node_type = T_element "wef:instance");
let name = node # required_string_attribute "name" in
let description = node # required_string_attribute "description" in
let inst = { i_name = Instance name;
i_description = description } in
let inst' =
( try
let old_inst = Db.Instance.get db (Instance name) in
(* Instance exists! *)
if old_inst <> inst then (
match onconflict with
`Fail ->
raise (Conflict("Instance " ^ name))
| `Overwrite ->
Db.Instance.update db inst;
inst
| `Only_add ->
old_inst
)
else inst
with
No_such_instance _ ->
Db.Instance.insert db inst;
inst
) in
node # iter_nodes (trav_perm_or_day inst')
and trav_perm_or_day inst node =
match node # node_type with
T_element "wef:permission" ->
trav_permission inst node
| T_element "wef:day" ->
trav_day inst node
| _ ->
assert false
and trav_permission inst node =
assert(node # node_type = T_element "wef:permission");
node # iter_nodes (trav_allow inst)
and trav_allow inst node =
assert(node # node_type = T_element "wef:allow");
let uname = node # required_string_attribute "user" in
let right =
match node # required_string_attribute "right" with
"read" -> `Read
| "write" -> `Write
| "owner" -> `Owner
| _ -> assert false in
let pset = Db.Permission.get db inst.i_name in
if List.mem_assoc (User uname) pset.p_set then (
(* There is already a right for this user *)
let old_right = List.assoc (User uname) pset.p_set in
if old_right <> right then (
match onconflict with
`Fail ->
raise (Conflict("Instance " ^ string_of_inst_name inst.i_name ^
", permission of user " ^ uname))
| `Overwrite ->
let pset' =
{ p_instance = inst.i_name;
p_set =
List.map
(fun (u,r) ->
if u = User uname then
(u, right)
else
(u, r)
)
pset.p_set
} in
Db.Permission.update db pset'
| `Only_add ->
()
)
) else (
let pset' =
{ p_instance = inst.i_name;
p_set = (User uname, right) :: pset.p_set
} in
Db.Permission.update db pset'
)
and trav_day inst node =
assert(node # node_type = T_element "wef:day");
let date_str = node # required_string_attribute "date" in
let date = Date.from_string date_str in
let entries_as_tuples =
Array.of_list
(List.map
(trav_entry date inst)
(node # sub_nodes)) in
let entries =
Array.init (Array.length entries_as_tuples)
(fun k ->
let (start_time, end_time, duration, project, description) =
entries_as_tuples.(k) in
{ e_id = None;
e_instance = inst.i_name;
e_day = date;
e_index = k;
e_start = start_time;
e_end = end_time;
e_duration = duration;
e_project = project;
e_description = description;
}
) in
let old_day = Db.Entry.get db inst.i_name date in
if old_day.d_entries <> [] then (
(* Compare old_entries and entries: *)
let old_entries' =
Array.of_list
(List.map
(fun e ->
{ e with e_id = None }) old_day.d_entries) in
if old_entries' <> entries then (
match onconflict with
`Fail ->
raise (Conflict("Instance " ^ string_of_inst_name inst.i_name ^
", date " ^ date_str))
| `Overwrite ->
let day =
{ d_instance = inst.i_name;
d_day = date;
d_entries = Array.to_list entries;
} in
Db.Entry.update db day
| `Only_add ->
()
)
) else (
let day =
{ d_instance = inst.i_name;
d_day = date;
d_entries = Array.to_list entries;
} in
Db.Entry.update db day
)
and trav_entry date inst node =
assert(node # node_type = T_element "wef:entry");
let start_time = node # optional_string_attribute "start-time" in
let end_time = node # optional_string_attribute "end-time" in
let duration = node # optional_string_attribute "duration" in
let project = node # required_string_attribute "project" in
let description = node # required_string_attribute "description" in
((match start_time with
Some d -> Some(Time.from_string d) | None -> None),
(match end_time with
Some d -> Some(Time.from_string d) | None -> None),
(match duration with
Some d -> Some(Interval.from_string d) | None -> None),
project,
description)
and trav_start node =
match node # node_type with
T_element "wef:dataset" ->
trav_dataset node
| T_element "wef:users" ->
trav_users node
| T_element "wef:instances" ->
trav_instances node
| _ ->
failwith "Invalid XML starting point"
in
let config =
{ default_namespace_config with
(* warner = XXX; *) (* TODO *)
encoding = Const.internal_charset;
recognize_standalone_declaration = false;
} in
let toplevel_id = Private(allocate_private_id()) in
let wef_dtd_file = Filename.concat Const.ui_dir "wef.dtd" in
let resolver =
new combine
[ lookup_public_id_as_file
[ wef_public_id, wef_dtd_file ];
lookup_system_id_as_file
[ wef_system_id, wef_dtd_file ];
new resolve_as_file ();
new resolve_read_this_channel ~id:toplevel_id inp;
] in
let doc =
parse_document_entity
config
(ExtID(toplevel_id, resolver))
default_spec
in
trav_start doc#root
;;
(* ======================================================================
* History:
*
* $Log: db_xml.ml,v $
* Revision 1.3 2003/03/23 11:59:14 gerd
* GPL
*
* Revision 1.2 2003/02/07 14:18:52 gerd
* wef.dtd is taken from install dir
*
* Revision 1.1 2003/01/16 00:31:10 gerd
* Initial revision.
*
*
*)
