(*
* <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: startpage.ml,v 1.7 2003/03/23 20:03:50 gerd Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_dialog
open Wd_run_cgi
open Wd_types
open Netcgi_types
open Db.Types
let gecko_re = Netstring_pcre.regexp ".*Gecko/";;
let mozold_re = Netstring_pcre.regexp ".*Mozilla/[1234]";;
let msie_re = Netstring_pcre.regexp ".*MSIE";; (* but MSIE is also mozold! *)
let msie_old_re = Netstring_pcre.regexp ".*MSIE [1234]";;
let msie_50_re = Netstring_pcre.regexp ".*MSIE 5.0";;
let opera_re = Netstring_pcre.regexp ".*Opera";; (* normally also MSIE *)
class startpage db universe name env =
object (self)
inherit dialog universe name env
method prepare_page() =
(* Create a new session (empty by default): *)
let session = !Registry.new_session universe env in
(* Check whether there is a cookie containing the browser capabilities: *)
let cgi = (self # environment).cgi in
let cgienv = cgi # environment in
let cookies = cgienv # cookies in
let grid =
try
List.assoc "wtimer-browser-cap" cookies
with
Not_found ->
(* No cookie: Browser sniffing as fallback method *)
let user_agent = cgienv # user_agent in
if Netstring_pcre.string_match gecko_re user_agent 0 <> None then
"dynamic" (* for Gecko-based browsers *)
else
if Netstring_pcre.string_match opera_re user_agent 0 <> None then
"fixed" (* Operas work best with "fixed" *)
else
if Netstring_pcre.string_match msie_re user_agent 0 <> None
then (
if Netstring_pcre.string_match msie_50_re user_agent 0 <>
None &&
Netstring_pcre.string_match msie_old_re user_agent 0 <>
None then
"legacy" (* for older Internet Explorers *)
else
"960" (* for modern Internet Explorers *)
)
else
if Netstring_pcre.string_match mozold_re user_agent 0 <> None
then (* for Netscapes until 4.XX *)
"legacy"
else
"960" (* default *)
in
session # set_variable "grid" (Enum_value [grid]);
(* Save the session: *)
self # set_variable "session" (Dialog_value (Some session));
self # set_variable "version" (String_value Const.version);
method handle() =
if self # event <> No_event then begin
let grid = self # enum_variable "session.grid" in
(* If demanded, store a new cookie: *)
let grid_cookie = self # enum_variable "session.grid-cookie" in
if grid_cookie = [ "yes" ] then begin
(* The CGI activation object has already set the header, but we
* can modify it by calling the cgienv methods. Not very elegant,
* and to be improved.
*)
let year = 86400.0 *. 365.0 in
let cgi = (self # environment).cgi in
let rh = (self # environment).response_header in
rh.rh_set_cookie <- [ { cookie_name = "wtimer-browser-cap";
cookie_value = String.concat "" grid;
cookie_expires = Some (Unix.time() +. year);
cookie_domain = None;
cookie_path = None;
cookie_secure = cgi#environment#cgi_https;
} ];
end;
(* Set the button implementation from the grid: *)
if grid = [ "dynamic" ] then
self # set_variable "session.button-impl" (String_value "richbutton");
(* Handle the event: *)
match self#event with
Button("start") ->
(* Login by REMOTE_USER and trust the web server *)
let session =
match self # dialog_variable "session" with
None -> assert false
| Some s -> s in
let cgi = (self # environment).cgi in
let cgienv = cgi # environment in
let user = cgienv # cgi_remote_user in
let user_passes =
( try
let urec = Db.User.get db (User user) in
urec.u_login
with
No_such_user _ -> false
| Not_found -> false
) in
if user_passes then begin
let now = Unix.localtime(Unix.time()) in
let now_str = Printf.sprintf "%04d-%02d-01"
(now.Unix.tm_year + 1900)
(now.Unix.tm_mon + 1) in
session # set_variable "login-user" (String_value user);
session # set_variable "passwd-hash" (String_value "n/a");
session # set_variable "current-sheet" (String_value user);
session # set_variable "current-date" (String_value now_str);
let next_dlg =
!Registry.new_editor universe env (Some session) in
raise(Change_dialog next_dlg)
end
else
raise Definitions.Login_not_permitted
| Button("login") ->
(* Login by entered user and password *)
let session =
match self # dialog_variable "session" with
None -> assert false
| Some s -> s in
let user = self # string_variable "entered-user" in
let pw = self # string_variable "entered-password" in
(* Check password: *)
let user_passes =
( try
let urec = Db.User.get db (User user) in
match urec.u_password with
None -> raise Not_found
| Some upw ->
if Db.User.encrypt_password pw <> upw then
raise Not_found;
urec.u_login
with
No_such_user _ -> false
| Not_found -> false
) in
if user_passes then begin
let now = Unix.localtime(Unix.time()) in
let now_str = Printf.sprintf "%04d-%02d-01"
(now.Unix.tm_year + 1900)
(now.Unix.tm_mon + 1) in
session # set_variable "login-user" (String_value user);
session # set_variable "passwd-hash"
(String_value (Digest.string pw));
session # set_variable "current-sheet" (String_value user);
session # set_variable "current-date" (String_value now_str);
let next_dlg =
!Registry.new_editor universe env (Some session) in
raise(Change_dialog next_dlg)
end
else
self # set_variable "bad-password" (String_value "yes")
| _ ->
()
end
end
;;
Registry.new_startpage :=
fun universe env ->
let dlg = universe # create env "startpage" in
dlg
;;
(* ======================================================================
* History:
*
* $Log: startpage.ml,v $
* Revision 1.7 2003/03/23 20:03:50 gerd
* Updates
*
* Revision 1.6 2003/03/23 11:59:14 gerd
* GPL
*
* Revision 1.5 2003/02/16 21:35:15 gerd
* Renamed ui:longbutton into ui:richbutton
*
* Revision 1.4 2003/02/07 16:18:10 gerd
* wd-onstartup-call-handle activated
* startpage: case No_event explicitly handled
*
* Revision 1.3 2003/02/03 01:28:59 gerd
* Continued.
*
* Revision 1.2 2003/01/16 00:39:25 gerd
* Continued.
*
* Revision 1.1 2002/11/16 12:34:51 gerd
* Initial revision
*
*
*)
