(*
* <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
*
*
*)