(* * <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_password.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 class admin_password db universe name env = object (self) inherit dialog universe name env inherit error_behaviour method private check_auth () = check_auth db (self # dialog_variable "session") method private change_password () = let login_user = self # string_variable "session.current-sheet" in let login = User login_user in let login_pw = self # string_variable "pw-login" in let user = self # string_variable "pw-user" in let user_pw1 = self # string_variable "pw-new" in let user_pw2 = self # string_variable "pw-again" in (* First check that [login_user] has password [login_pw]: *) let login_record = Db_ac.User.get db login login in let login_pw_enc = Db.User.encrypt_password login_pw in if (login_record.u_password <> Some login_pw_enc) then ( self # add_message "error-bad-password"; ) else ( (* Second check that [user_pw1] is identical to [user_pw2]: *) if user_pw1 <> user_pw2 then ( self # add_message "error-different-passwords" ) else ( (* Change password: *) let user_pw_enc = Db.User.encrypt_password user_pw1 in let user_record = Db_ac.User.get db login (User user) in Db_ac.User.update db login { user_record with u_password = Some user_pw_enc; u_login = true; }; Db.Connection.commit db; self # add_message "ok" ) ) method private clear_password_fields() = self # set_variable "pw-login" (String_value ""); self # set_variable "pw-new" (String_value ""); self # set_variable "pw-again" (String_value ""); 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() = (* Create the list of users whose password can be changed: *) let login = User (self # string_variable "session.login-user") in let login_record = Db_ac.User.get db login login in let users = if login_record.u_admin then Db_ac.User.list db login else [login_record] in self # set_variable "pw-userlist" (Dyn_enum_value (List.sort (fun (a,_) (b,_) -> Pervasives.compare a b) (List.map (fun user -> match user.u_name with User name -> (name, name ^ " (" ^ user.u_description ^ ")") ) users ) ) ); self # clear_password_fields() method private try_handle() = self # set_variable "message" (Enum_value []); 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 -> ( match self # event with Button "pw-change" -> self # change_password() | Button "cont-error" -> self # set_next_page "password" | _ -> () ) ) end ;; Registry.new_admin_password := fun universe env opt_session -> let dlg = universe # create env "admin-password" in dlg # set_variable "session" (Dialog_value opt_session); dlg ;; (* ====================================================================== * History: * * $Log: admin_password.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 * * *)