(*
* <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_accounts.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
(* Access control:
* - admins can edit all rows fully
* - unprivileged users can edit only rows they own
* - unprivileged users can never set the 'admin' checkbox
*)
exception Force_dialog of dialog_type ;;
(* Like Change_dialog, but bypasses the check on unsaved changes *)
type login = [ `No_password | `Disabled | `Enabled ] ;;
type row = { r_name : string;
r_is_new : bool;
r_description : string;
r_login : login;
r_admin : bool;
r_editable : bool;
r_delete : bool;
}
;;
let find_pos f l =
let rec find n =
if n >= Array.length l then
n
else
let x = l.(n) in
if f x then n else find (n+1)
in
find 0
;;
let enum_bool =
function
false -> Enum_value [ "no" ]
| true -> Enum_value [ "yes" ]
;;
let enum_login =
function
`No_password -> Enum_value [ "no-password" ]
| `Disabled -> Enum_value [ "disabled" ]
| `Enabled -> Enum_value [ "enabled" ]
;;
class admin_accounts config db universe name env =
object (self)
inherit dialog universe name env
inherit error_behaviour
val mutable rows = [| |] (* see read_rows, write_rows *)
method private check_auth () =
check_auth db (self # dialog_variable "session")
method private load_rows() =
(* Load all rows from db *)
let login_dlg = Get_config.bool_option config "login-dialog" in
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 users = Db_ac.User.list db login in (* load from db *)
let rlist =
Array.of_list
(List.map
(fun u ->
{ r_name = (match u.u_name with User n -> n);
r_is_new = false;
r_description = u.u_description;
r_login = (match u.u_password, u.u_login with
None, _ ->
if login_dlg then `No_password else `Disabled
| _, true ->
`Enabled
| _, false ->
`Disabled);
r_admin = u.u_admin;
r_editable = admin || u.u_name = login;
r_delete = false;
}
)
users
) in
Array.sort (fun a b -> Pervasives.compare a.r_name b.r_name) rlist;
rows <- rlist;
self # set_variable "checksum" (String_value (self # checksum()));
self # set_variable "admin" (Enum_value [ if admin then "yes" else "no" ]);
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 user and instance from database: *)
Db_ac.User.delete db login (User r.r_name);
(* Get the instances to delete: *)
let inst_names = self # sheets_to_delete() in
List.iter (Db_ac.Instance.delete db login) inst_names;
)
) else (
if r.r_name <> "" then ( (* empty names are ignored *)
if r.r_is_new then (
(* Create new user and new instance: *)
let user =
{ u_name = User r.r_name;
u_description = r.r_description;
u_password = None;
u_login = true; (* Usually, there is no password *)
u_admin = r.r_admin;
} in
let inst =
{ i_name = Instance r.r_name;
i_description = r.r_description;
} in
Db_ac.User.insert db login user;
Db_ac.Instance.insert db login inst;
(* Change ownership of inst: *)
Db_ac.Permission.update db login
{ p_instance = inst.i_name;
p_set = [ user.u_name, `Owner ]
}
) else (
(* Update user: *)
let user_db = Db_ac.User.get db login (User r.r_name) in
let user = { user_db with
u_description = r.r_description;
u_login = r.r_login = `Enabled;
u_admin = r.r_admin;
} in
Db_ac.User.update db login user;
)
)
)
)
done;
(* Check: it is not allowed to delete the last admin. *)
let users = Db_ac.User.list db login in
if not (List.exists (fun u -> u.u_admin) users) then
failwith "Cannot delete the last administrator";
(* 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\" login=%s admin=%b edit=%b del=%b\n"
(String.escaped row.r_name)
row.r_is_new
(String.escaped row.r_description)
(match row.r_login with
`No_password -> "no-password"
| `Enabled -> "enabled"
| `Disabled -> "disabled")
row.r_admin
row.r_editable
row.r_delete
)
rows;
Buffer.contents buffer
method private write_rows () =
(* Set the dialog variable to the contents of [rows] *)
let make_id id = string_of_int id in
let first_new_row = find_pos (fun row -> row.r_is_new) rows in
self # set_variable "acc-first-new-row"
(String_value (string_of_int first_new_row));
self # set_variable "acc-delete"
(Alist_value
(Array.to_list
(Array.mapi
(fun id row -> make_id id, enum_bool row.r_delete )
rows)));
self # set_variable "acc-edit"
(Alist_value
(Array.to_list
(Array.mapi
(fun id row -> make_id id, enum_bool row.r_editable )
rows)));
self # set_variable "acc-name"
(Alist_value
(Array.to_list
(Array.mapi
(fun id row -> make_id id, String_value row.r_name )
rows)));
self # set_variable "acc-comment"
(Alist_value
(Array.to_list
(Array.mapi
(fun id row -> make_id id, String_value row.r_description )
rows)));
self # set_variable "acc-admin"
(Alist_value
(Array.to_list
(Array.mapi
(fun id row -> make_id id, enum_bool row.r_admin )
rows)));
self # set_variable "acc-login"
(Alist_value
(Array.to_list
(Array.mapi
(fun id row -> make_id id, enum_login row.r_login )
rows)));
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 found_fnr_str = self # string_variable "acc-first-new-row" in
let found_fnr = int_of_string found_fnr_str in
let found_rows =
Array.of_list
(List.map
(fun (nr_str, name_str) ->
let nr = int_of_string nr_str in
let row =
{ r_name =
(match name_str with String_value n -> n
| _ -> assert false);
r_is_new = (nr >= found_fnr);
r_description = lookup_str "acc-comment" nr_str;
r_login = (match lookup_enum "acc-login" nr_str with
["no-password"] -> `No_password
| ["enabled"] -> `Enabled
| ["disabled"] | [] -> `Disabled
| _ -> assert false);
r_admin = (lookup_enum "acc-admin" nr_str = [ "yes" ]);
r_editable = (lookup_enum "acc-edit" nr_str = [ "yes" ]);
r_delete = (lookup_enum "acc-delete" nr_str = [ "yes" ]);
}
in
row
)
(self # alist_variable "acc-name")
)
in
rows <- found_rows
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.User.exists db login (User name) ||
Db_ac.Instance.exists db login (Instance name) then occurs := true
)
done;
!occurs
)
method private admin_exists =
(* Returns [true] if there is at least one admin with password *)
let occurs = ref false in
for i = 0 to Array.length rows - 1 do
if rows.(i).r_name <> "" && not rows.(i).r_delete && rows.(i).r_admin
&& rows.(i).r_login = `Enabled
then occurs := true
done;
!occurs
method private sheets_to_delete () =
(* Returns a list of all sheets (as names) that are deleted because of
* deleted user accounts. These are all sheets that are only owned by
* a user to delete
*)
let login = User (self # string_variable "session.login-user") in
let accounts_to_delete = (* names of all accounts to delete *)
List.map
(fun row -> User row.r_name)
(List.filter
(fun row -> not row.r_is_new && row.r_editable && row.r_delete)
(Array.to_list rows)
)
in
List.map
(fun sheet -> sheet.i_name)
(List.filter
(fun sheet ->
(* Who owns this sheet? *)
try
let p = (Db_ac.Permission.get db login sheet.i_name).p_set in
List.length p = 1 && (snd(List.hd p) = `Owner) &&
List.mem (fst(List.hd p)) accounts_to_delete
with
Db_ac.Types.Permission_denied -> false
)
(Db_ac.Instance.list db login)
)
method private save () =
(* Only change to the dialog "confirm" *)
if self # double_names then (
self # add_message "error-double-names"
) else (
if not ( self # admin_exists ) then (
self # add_message "warning-no-admin"
) else (
raise(Change_page "confirm")
)
)
method private really_save() =
if self # double_names then (
self # add_message "error-double-names";
) else (
self # store_rows();
self # add_message "saved";
self # load_rows();
);
self # set_next_page "accounts"
method private new_line () =
let row =
{ r_name = "";
r_is_new = true;
r_description = "";
r_login = `No_password;
r_admin = false;
r_editable = true;
r_delete = false;
} in
rows <- Array.append rows [| row |]
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;
if self # page_name = "confirm" then begin
(* Init var acc-del-sheets *)
self # read_rows();
let sheets = self # sheets_to_delete() in
self # set_variable "acc-del-sheets"
(Dyn_enum_value
((List.map (fun (Instance sheet) -> (sheet,sheet)))
sheets));
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 "accounts-new-line" ->
self # new_line()
| Button "accounts-save" ->
self # save()
| Button "confirm-ok" ->
self # really_save()
| Button "confirm-cancel" ->
self # set_next_page "accounts"
| Button "unsaved-save" ->
self # set_variable "deferred-dialog"
(Dialog_value None);
self # save()
| Button "unsaved-discard" ->
self # activate_deferred_dialog ~force:true ();
| Button "unsaved-cancel" ->
self # set_variable "deferred-dialog"
(Dialog_value None);
raise(Change_page "accounts")
| Button "cont-error" ->
self # set_next_page "accounts"
| _ ->
()
);
(* 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_accounts :=
fun universe env opt_session ->
let dlg = universe # create env "admin-accounts" in
dlg # set_variable "session" (Dialog_value opt_session);
dlg
;;
(* ======================================================================
* History:
*
* $Log: admin_accounts.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:51 gerd
* Initial revision
*
*
*)
