(* * <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 6 2004-01-19 17:12:34Z gerd $ * ---------------------------------------------------------------------- * *) 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; mutable 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 toggle_delete id_str = let id = int_of_string id_str in let row = rows.(id) in row.r_delete <- not row.r_delete 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() | Image_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" | Indexed_image_button("accounts-del", id, _, _) -> self # toggle_delete id | _ -> () ); (* 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 ;;