(* * <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 23 2015-01-14 16:24:21Z gerd $ * ---------------------------------------------------------------------- * *) open Wd_dialog open Wd_run_cgi open Wd_types open Netcgi 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 grid = try Cookie.value (List.find (fun coo -> Cookie.name coo = "wtimer-browser-cap") cgienv#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 "fixed" (* 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]); (* session # set_variable "lang" (String_value "en"); *) (* 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 <- [ { Nethttp.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 ;;