(*
* <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: admin_access.ml,v 1.5 2003/03/23 11:59:13 gerd Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_dialog
open Wd_run_cgi
open Wd_types
open Db.Types
open Definitions
exception Force_dialog of dialog_type ;;
(* Like Change_dialog, but bypasses the check on unsaved changes *)
type row = { r_name : string;
r_is_new : bool;
r_delete : bool;
r_description : string;
r_editable : bool;
r_acl : (user_name * perm_type) list;
}
;;
let enum_bool =
function
false -> Enum_value [ "no" ]
| true -> Enum_value [ "yes" ]
;;
class admin_access db universe name env =
object (self)
inherit dialog universe name env
inherit error_behaviour
val mutable rows = [| |] (* see read_rows, write_rows *)
val mutable users = []
method private check_auth () =
check_auth db (self # dialog_variable "session")
method private load_rows() =
(* Load all rows from db *)
let login = User (self # string_variable "session.login-user") in
let luser = Db_ac.User.get db login login in
let admin = luser.u_admin in
let instances = Db_ac.Instance.list db login in
let found_rows =
List.flatten
(List.map
(fun inst ->
try
let p = Db_ac.Permission.get db login inst.i_name in
(* may raise Permission_denied *)
[ { r_name = (match inst.i_name with Instance n -> n);
r_is_new = false;
r_delete = false;
r_description = inst.i_description;
r_editable = true;
r_acl = p.p_set;
}
]
with
Db_ac.Types.Permission_denied ->
[]
)
instances
)
in
let found_rows' =
List.sort (fun a b -> Pervasives.compare a.r_name b.r_name) found_rows in
rows <- Array.of_list found_rows';
self # set_variable "checksum" (String_value (self # checksum()));
users <- List.sort (fun a b -> Pervasives.compare a b)
(List.map (fun u -> match u.u_name with User n -> n)
(Db_ac.User.list db login));
self # write_rows();
method private store_rows() =
(* store rows into db *)
let login = User (self # string_variable "session.login-user") in
for i = 0 to Array.length rows - 1 do
let r = rows.(i) in
if r.r_editable then (
if r.r_delete then (
if not r.r_is_new then (
(* Delete the instance from the database: *)
Db_ac.Instance.delete db login (Instance r.r_name)
)
) else (
(* insert/update *)
if r.r_name <> "" then ( (* empty names are ignored *)
if r.r_is_new then (
(* Create new instance: *)
let inst =
{ i_name = Instance r.r_name;
i_description = r.r_description;
} in
Db_ac.Instance.insert db login inst;
(* Update permissions: *)
let p =
{ p_instance = Instance r.r_name;
p_set = r.r_acl;
} in
Db_ac.Permission.update db login p;
)
else (
(* Update Instance *)
let inst =
{ i_name = Instance r.r_name;
i_description = r.r_description;
} in
Db_ac.Instance.update db login inst;
(* Update permissions: *)
let p =
{ p_instance = Instance r.r_name;
p_set = r.r_acl;
} in
Db_ac.Permission.update db login p;
)
)
)
)
done;
(* Finally commit *)
Db.Connection.commit db
method private checksum () =
(* Returns the checksum of [rows] *)
let v = self # dump_rows() in
Digest.to_hex (Digest.string v)
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
Array.iter
(fun row ->
Printf.bprintf
buffer
"name=\"%s\" new=%b descr=\"%s\" edit=%b del=%b acl=\"%s\"\n"
(String.escaped row.r_name)
row.r_is_new
(String.escaped row.r_description)
row.r_editable
row.r_delete
(String.concat ";"
(List.map
(fun (User user, perm) ->
(String.escaped ("\"" ^ String.escaped user ^ "\"") ^ "," ^
(match perm with
`Read -> "R"
| `Write -> "W"
| `Owner -> "O")))
(List.sort
(fun (User a,_) (User b,_) -> Pervasives.compare a b)
row.r_acl)))
)
rows;
Buffer.contents buffer
method private write_rows () =
(* Set the dialog variables to the contents of [rows] *)
List.iter
(fun (dlgvar,getval) ->
let alist = Alist_value
(Array.to_list
(Array.mapi
(fun id row -> (string_of_int id, getval id row))
rows)) in
self # set_variable dlgvar alist
)
[ "inst-del", (fun id row -> enum_bool row.r_delete);
"inst-name", (fun id row -> String_value row.r_name);
"inst-descr", (fun id row -> String_value row.r_description);
"inst-edit", (fun id row -> String_value(if row.r_editable
then (
if row.r_is_new then
"new"
else
"yes")
else "no"));
"acl-read", (fun id row ->
Dyn_enum_value
(List.map
(fun (User user, perm) -> (user, user))
(List.filter
(fun (_,perm) -> perm = `Read)
row.r_acl)));
"acl-write", (fun id row ->
Dyn_enum_value
(List.map
(fun (User user, perm) -> (user, user))
(List.filter
(fun (_,perm) -> perm = `Write)
row.r_acl)));
"acl-owner", (fun id row ->
Dyn_enum_value
(List.map
(fun (User user, perm) -> (user, user))
(List.filter
(fun (_,perm) -> perm = `Owner)
row.r_acl)));
];
self # set_variable "acl-users"
(Dyn_enum_value (List.map (fun n -> (n,n)) users));
self # set_variable "modified"
(String_value (if self # is_modified then "yes" else "no"));
method private read_rows () =
(* Read the dialog variables and store contents as [row list] in the
* instance variable [rows].
*)
let lookup_str = self # lookup_string_variable in (* abbr *)
let lookup_enum = self # lookup_enum_variable in (* abbr *)
let lookup_dynenum = self # lookup_dyn_enum_variable in (* abbr *)
let found_rows =
Array.of_list
(List.map
(fun (id_str, name_str) ->
let id = int_of_string id_str in
let edit = lookup_str "inst-edit" id_str in
let row =
{ r_name = lookup_str "inst-name" id_str;
r_is_new = (edit = "new");
r_delete = (lookup_enum "inst-del" id_str = [ "yes" ]);
r_description = lookup_str "inst-descr" id_str;
r_editable = (edit <> "no");
r_acl = (List.map
(fun (user,_) -> (User user, `Read))
(lookup_dynenum "acl-read" id_str) @
List.map
(fun (user,_) -> (User user, `Write))
(lookup_dynenum "acl-write" id_str) @
List.map
(fun (user,_) -> (User user, `Owner))
(lookup_dynenum "acl-owner" id_str));
} in
row
)
(self # alist_variable "inst-name")
)
in
rows <- found_rows;
users <- List.map fst (self # dyn_enum_variable "acl-users");
method private double_names =
(* [true] if there are double names *)
(* First check [rows] against itself: *)
let login = User (self # string_variable "session.login-user") in
let occurs = ref false in
for i = 0 to Array.length rows - 1 do
let name = rows.(i).r_name in
if name <> "" && not rows.(i).r_delete then (
for j = i+1 to Array.length rows - 1 do
if name = rows.(j).r_name then occurs := true
done
)
done;
(* Otherwise check the new rows against the database: *)
!occurs || (
for i = 0 to Array.length rows - 1 do
let name = rows.(i).r_name in
if rows.(i).r_is_new && not rows.(i).r_delete then (
if Db_ac.Instance.exists db login (Instance name) then occurs := true
)
done;
!occurs
)
method private bad_owner =
(* [true] if there is a primary sheet that is not owned by the
* corresponding user
*)
let login = User (self # string_variable "session.login-user") in
let occurs = ref false in
for i = 0 to Array.length rows - 1 do
let name = rows.(i).r_name in
if Db_ac.User.exists db login (User name) then (
(* This is a primary sheet *)
try
if List.assoc (User name) rows.(i).r_acl <> `Owner then
occurs := true
with
Not_found -> occurs := true
)
done;
!occurs
method private missing_owner =
(* [true] if there is a sheet without owner *)
let occurs = ref false in
for i = 0 to Array.length rows - 1 do
if not (List.exists (fun (_,perm) -> perm = `Owner) rows.(i).r_acl) then
occurs := true
done;
!occurs
method private save () =
let error = ref false in
if self # double_names then ( self # add_message "error-double-names";
error := true );
if self # bad_owner then ( self # add_message "error-bad-ownership";
error := true );
if self # missing_owner then ( self # add_message "error-missing-ownership";
error := true );
if (not !error) then (
self # store_rows();
self # add_message "saved";
self # load_rows();
self # set_variable "acl-edit" (Dyn_enum_value []);
)
method private new_line() =
let login = User (self # string_variable "session.login-user") in
let row =
{ r_name = "";
r_is_new = true;
r_description = "";
r_editable = true;
r_delete = false;
r_acl = [ login, `Owner ];
} in
rows <- Array.append rows [| row |];
self # set_variable "acl-edit" (Dyn_enum_value []);
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_rows()
end
method private try_handle() =
(* Before anything else happens, parse the input boxes: *)
self # set_variable "message" (Enum_value []);
self # read_rows();
(* 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 or task menu button has been pressed: *)
try
raise(Change_dialog(Filemenu.handle (self :> dialog_type)
db self#event))
with
Filemenu.Not_competent ->
( try
raise(Change_dialog(Taskmenu.handle (self :> dialog_type) self#event))
with
Taskmenu.Not_competent ->
(* No, it is another button: *)
( match self # event with
Button "access-new" ->
self # new_line()
| Button "access-save" ->
self # save()
| Button "access-edit" ->
if (self # dyn_enum_variable "acl-edit") = [] then
self # add_message "error-nothing-selected"
| 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 "access-list")
| Button "cont-error" ->
self # set_next_page "access-list"
| _ ->
()
);
(* 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_admin_access :=
fun universe env opt_session ->
let dlg = universe # create env "admin-access" in
dlg # set_variable "session" (Dialog_value opt_session);
dlg
;;
(* ======================================================================
* History:
*
* $Log: admin_access.ml,v $
* Revision 1.5 2003/03/23 11:59:13 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:50 gerd
* Initial revision
*
*
*)
