(*
* <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: db.ml,v 1.9 2003/03/23 11:59:13 gerd Exp $
* ----------------------------------------------------------------------
*
*)
module Connection = Db_DBVARIANT.Connection
(* Db_pg.Connection for PostgreSQL
* Db_my.Connection for MySQL
*)
module Types = struct
open Db_types.Types
type user_name = User of string
type user = { u_name : user_name;
u_description : string;
u_password : string option;
u_login : bool;
u_admin : bool;
}
exception No_such_user of user_name
exception User_already_exists of user_name
type inst_name = Instance of string
type instance = { i_name : inst_name;
i_description : string;
}
exception No_such_instance of inst_name
exception Instance_already_exists of inst_name
type perm_type = [ `Write | `Read | `Owner ]
type perm_set = { p_instance : inst_name;
p_set : (user_name * perm_type) list;
}
type entry = { mutable e_id : int option;
e_instance : inst_name;
e_day : date;
e_index : int;
e_start : time option;
e_end : time option;
e_duration : interval option;
e_project : string;
e_description : string;
}
type day = { d_instance : inst_name;
d_day : date;
d_entries : entry list;
}
let string_of_user_name (User s) = s
let string_of_inst_name (Instance s) = s
end
module User = struct
open Types
open Db_types.Types
open Db_types
open Connection
open Printf
let list c =
let l = exec c "select name,description,password IS NULL,password,login,admin from users" in
List.map
(fun row ->
match row with
[n; d; p_null; p; l; a] ->
{ u_name = User n;
u_description = d;
u_password = if is_bool_true p_null then None else Some p;
u_login = is_bool_true l;
u_admin = is_bool_true a;
}
| _ ->
failwith "Db.User.list: Unexpected return list of SELECT"
)
l
let get c (User n) =
let l = exec c
(sprintf "select description,password IS NULL,password,login,admin from users where name = '%s'" (quote n)) in
match l with
[] ->
raise (No_such_user (User n))
| [row] ->
( match row with
[d; p_null; p; l; a] ->
{ u_name = User n;
u_description = d;
u_password = if is_bool_true p_null then None else Some p;
u_login = is_bool_true l;
u_admin = is_bool_true a;
}
| _ ->
failwith "Db.User.get: Unexpected return list of SELECT"
)
| _ ->
failwith "Db.User.get: Unexpected return list of SELECT"
let exists c uname =
let l = exec c
(sprintf "select count(*) from users where name = '%s'"
(quote (string_of_user_name uname))) in
match l with
[[ n ]] ->
int_of_string n > 0
| _ ->
failwith "Db.User.exists: Unexpected return list of SELECT"
let insert c u =
if exists c u.u_name then raise (User_already_exists u.u_name);
exec_nr c
(sprintf "insert into users (name,description,password,login,admin) values ('%s', '%s', %s, %s, %s)"
(quote (string_of_user_name u.u_name))
(quote u.u_description)
(match u.u_password with
None -> "NULL"
| Some pw -> "'" ^ quote pw ^ "'")
(if u.u_login then bool_true else bool_false)
(if u.u_admin then bool_true else bool_false)
)
let update c u =
if not (exists c u.u_name) then raise (No_such_user u.u_name);
exec_nr c
(sprintf "update users set description = '%s', password = %s, login = %s, admin = %s where name = '%s'"
(quote u.u_description)
(match u.u_password with
None -> "NULL"
| Some pw -> "'" ^ quote pw ^ "'")
(if u.u_login then bool_true else bool_false)
(if u.u_admin then bool_true else bool_false)
(quote (string_of_user_name u.u_name)))
let delete c uname =
if not (exists c uname) then raise (No_such_user uname);
exec_nr c
(sprintf "delete from users where name = '%s'"
(quote (string_of_user_name uname)));
if not have_on_delete_cascade then begin
exec_nr c
(sprintf "delete from permission where username = '%s'"
(quote (string_of_user_name uname)));
end
let encrypt_password pw =
Digest.to_hex (Digest.string pw)
end
module Instance = struct
open Types
open Db_types.Types
open Db_types
open Connection
open Printf
let list c =
let l = exec c "select name,description from instance" in
List.map
(fun row ->
match row with
[n; d] ->
{ i_name = Instance n;
i_description = d
}
| _ ->
failwith "Db.Instance.list: Unexpected return list of SELECT"
)
l
let get c iname =
let l = exec c
(sprintf "select description from instance where name = '%s'"
(quote (string_of_inst_name iname))) in
match l with
[] -> raise (No_such_instance iname)
| [[d]] ->
{ i_name = iname;
i_description = d
}
| _ ->
failwith "Db.Instance.get: Unexpected return list of SELECT"
let exists c iname =
let l = exec c
(sprintf "select count(*) from instance where name = '%s'"
(quote (string_of_inst_name iname))) in
match l with
[[ n ]] ->
int_of_string n > 0
| _ ->
failwith "Db.Instance.exists: Unexpected return list of SELECT"
let insert c i =
if exists c i.i_name then raise (Instance_already_exists i.i_name);
exec_nr c
(sprintf "insert into instance (name,description) values ('%s', '%s')"
(quote (string_of_inst_name i.i_name))
(quote i.i_description))
let update c i =
if not (exists c i.i_name) then raise (No_such_instance i.i_name);
exec_nr c
(sprintf "update instance set description = '%s' where name = '%s'"
(quote i.i_description)
(quote (string_of_inst_name i.i_name)))
let delete c iname =
if not (exists c iname) then raise (No_such_instance iname);
exec_nr c
(sprintf "delete from instance where name = '%s'"
(quote (string_of_inst_name iname)));
if not have_on_delete_cascade then begin
exec_nr c
(sprintf "delete from permission where instance = '%s'"
(quote (string_of_inst_name iname)));
exec_nr c
(sprintf "delete from entry where instance = '%s'"
(quote (string_of_inst_name iname)));
end
end
module Permission = struct
open Types
open Db_types.Types
open Db_types
open Connection
open Printf
let pt_map = [ `Read, "R";
`Write, "W";
`Owner, "O" ]
let pt_rev = List.map (fun (a,b) -> (b,a)) pt_map
let priority =
function
`Read -> 0
| `Write -> 1
| `Owner -> 2
let check c iname uname pt =
let query =
(* Include all rights with same priority as pt or higher priority *)
let pt_pri = priority pt in
let rights =
List.filter (fun (pt',_) -> priority pt' >= pt_pri) pt_map in
String.concat
" or "
(List.map (fun (_,c) -> "type = '" ^ c ^ "'") rights)
in
let l = exec c
(sprintf "select count(*) from permission \
where instance = '%s' \
and username = '%s' \
and (%s)"
(quote (string_of_inst_name iname))
(quote (string_of_user_name uname))
query) in
match l with
[[ n ]] ->
int_of_string n > 0
| _ ->
failwith "Db.Permission.check: Unexpected return list of SELECT"
let get c iname =
if not (Instance.exists c iname) then (raise (No_such_instance iname));
let l = exec c
(sprintf "select username, type from permission \
where instance = '%s'"
(quote (string_of_inst_name iname))) in
let l' = List.map
(fun e ->
match e with
[username; typ] ->
let typ' =
try List.assoc typ pt_rev
with Not_found ->
failwith "Db.Permission.get: Unexpected return value"
in
(User username,typ')
| _ ->
failwith "Db.Permission.get: Unexpected return list of SELECT"
)
l in
(* l': List of tuples (username, [type]) *)
let l'' = List.sort (fun (u,_) (v,_) -> compare u v) l' in
(* l'': The same list sorted by username *)
(* A function that makes l'' more dense: *)
let rec compress p =
match p with
(u1, t1) :: (u2, t2) :: p' when u1 = u2 ->
if priority t1 > priority t2 then
compress ((u1, t1) :: p')
else
compress ((u1, t2) :: p')
| (u, t) :: p' ->
(u, t) :: compress p'
| [] ->
[]
in
{ p_instance = iname;
p_set = compress l''
}
let delete c iname =
(* Internal function *)
exec_nr c (sprintf "delete from permission where instance = '%s'"
(quote (string_of_inst_name iname)))
let insert c iname p =
(* Internal function *)
List.iter
(fun (user_name, right) ->
exec_nr c (sprintf "insert into permission \
(instance,username,type) \
values ('%s','%s','%s')"
(quote (string_of_inst_name iname))
(quote (string_of_user_name user_name))
(List.assoc right pt_map))
)
p
let update c pset =
if not (Instance.exists c pset.p_instance) then
raise (No_such_instance pset.p_instance);
delete c pset.p_instance;
insert c pset.p_instance pset.p_set
end
module Entry = struct
open Types
open Db_types.Types
open Db_types
open Connection
open Printf
let list c iname start_date end_date =
if not (Instance.exists c iname) then raise (No_such_instance iname);
let l =
exec c (sprintf "select distinct(day) from entry \
where instance = '%s' \
and day >= '%s' \
and day <= '%s'"
(quote (string_of_inst_name iname))
(Date.to_string start_date)
(Date.to_string end_date)) in
List.map
(fun e ->
match e with
[ d ] ->
Date.from_string d
| _ ->
failwith "Db.Entry.list: Unexpected return list of SELECT"
)
l
let get c iname date =
if not (Instance.exists c iname) then
raise(No_such_instance iname);
let l =
exec c (sprintf "select id,row_index,period_start,period_start is null, \
period_end,period_end is null, \
duration,duration is null,project,description \
from entry \
where instance = '%s' \
and day = '%s'"
(quote (string_of_inst_name iname))
(Date.to_string date))
in
let l' =
List.map
(fun e ->
match e with
[id;index;period_s;period_s_null;period_e;period_e_null;
duration;duration_null;project;descr] ->
{ e_id = Some(int_of_string id);
e_instance = iname;
e_day = date;
e_index = int_of_string index;
e_start =
if is_bool_true period_s_null then
None
else
Some(Time.from_string period_s);
e_end =
if is_bool_true period_e_null then
None
else
Some(Time.from_string period_e);
e_duration =
if is_bool_true duration_null then
None
else
Some(Interval.from_string duration);
e_project = project;
e_description = descr;
}
| _ ->
failwith "Db.Entry.get: Unexpected return list of SELECT"
)
l
in
let l'' = List.sort (fun e e' -> compare e.e_index e'.e_index) l' in
{ d_instance = iname;
d_day = date;
d_entries = l'';
}
let delete c iname date =
(* Internal function *)
exec_nr c (sprintf "delete from entry \
where instance = '%s' \
and day = '%s'"
(quote (string_of_inst_name iname))
(Date.to_string date)
)
let insert c l =
(* Internal function *)
let opt_literal pre post f =
function
None -> "null"
| Some s -> pre ^ f s ^ post
in
List.iter
(fun e ->
let new_or_old_id =
match e.e_id with
Some id -> string_of_int id
| None -> expr_next_serial_value "entry" "id"
in
exec_nr c (sprintf "insert into entry \
(id,instance,day,row_index,period_start,period_end, \
duration,project,description) \
values \
(%s,'%s','%s',%d,%s,%s,%s,'%s','%s')"
new_or_old_id
(quote (string_of_inst_name e.e_instance))
(Date.to_string e.e_day)
e.e_index
(opt_literal
(have_time_keyword ^ " '") "'" Time.to_string e.e_start)
(opt_literal
(have_time_keyword ^ " '") "'" Time.to_string e.e_end)
(opt_literal
(have_interval_keyword ^ " '")
"'" Interval.to_string e.e_duration)
(quote e.e_project)
(quote e.e_description)
);
match e.e_id with
None ->
e.e_id <- Some(get_last_serial_value c "entry" "id")
| Some _ -> ()
)
l
let update c day =
if not (Instance.exists c day.d_instance) then
raise(No_such_instance day.d_instance);
(* Check plausibility: *)
if List.exists (fun e -> e.e_day <> day.d_day) day.d_entries then
invalid_arg "Db.Entry.update: invalid date found";
if List.exists (fun e -> e.e_instance <> day.d_instance) day.d_entries then
invalid_arg "Db.Entry.update: invalid instance found";
(* Check that every index occurs at most once: *)
let h = Hashtbl.create 10 in
List.iter
(fun e ->
if Hashtbl.mem h e.e_index then
invalid_arg "Db.Entry.update: index occurs more than once";
Hashtbl.add h e.e_index ()
)
day.d_entries;
(* Delete the day, and insert it again: *)
delete c day.d_instance day.d_day;
insert c day.d_entries
end
module Session = struct
open Wd_types
open Connection
open Printf
exception Invalid_session_checksum = Wd_dialog.Invalid_session_checksum
exception Session_not_found = Wd_dialog.Session_not_found
class db_session_manager db : session_manager_type =
Wd_dialog.database_session_manager
~allocate:(fun () ->
(* Delete very old records: *)
exec_nr
db
(sprintf "delete from wd_session \
where last_used < (current_date - %s)"
(Connection.day_interval 7)
);
(* Compute a new key: *)
exec_nr
db
(sprintf "insert into wd_session \
(id, skey, svalue, schecksum, last_used) \
values (%s, null, '', '', current_date)"
(expr_next_serial_value "wd_session" "id"));
get_last_serial_value db "wd_session" "id")
~insert:(fun id key ->
exec_nr
db
(sprintf
"update wd_session set skey = '%s' where id = %d" key id);
)
~update:(fun id key value checksum ->
exec_nr
db
(sprintf "update wd_session \
set svalue = '%s', \
schecksum = '%s', \
last_used = current_date \
where skey = '%s'"
value
checksum
key);
commit db;
)
~lookup:(fun id key ->
let slice_length = 7000 in
(* Retrieve the checksum: *)
let checksum =
let rows =
exec db
(sprintf
"select schecksum from wd_session where skey = '%s'"
(quote key)) in
match rows with
[ [ v_checksum ] ] -> v_checksum
| _ -> raise Session_not_found
in
(* Now load the session string *)
let slices = ref [] in
let last_length = ref 1 in
(* 0 means: end of string reached *)
let pos = ref 1 in
while !last_length <> 0 do
let rows =
exec db
(sprintf "select substring(svalue from %d for %d) \
from wd_session where skey = '%s'"
!pos
slice_length
(quote key)) in
( match rows with
[ [ v ] ] ->
slices := v :: !slices;
pos := !pos + String.length v;
last_length := String.length v
| _ ->
assert false
)
done;
(* Concatenate the slices and create the session object *)
let value =
String.concat "" (List.rev !slices) in
(value, checksum)
)
()
end
(* ======================================================================
* History:
*
* $Log: db.ml,v $
* Revision 1.9 2003/03/23 11:59:13 gerd
* GPL
*
* Revision 1.8 2003/03/09 17:56:49 gerd
* Using now the new database_session_manager class
*
* Revision 1.7 2003/02/07 15:34:34 gerd
* Work around limitation in ocamlodbc: long session strings
* are retrieved slice by slice
*
* Revision 1.6 2003/01/16 01:42:03 gerd
* MySQL port
*
* Revision 1.5 2003/01/16 00:39:25 gerd
* Continued.
*
* Revision 1.4 2002/11/20 21:32:46 gerd
* Added u_password, u_login, u_admin
*
* Revision 1.3 2002/11/16 12:34:41 gerd
* Moved date, time, interval to Db_types
*
* Revision 1.2 2002/10/12 23:08:32 gerd
* Moved date_rec, time_rec, interval_rec to Types module
*
* Revision 1.1 2002/10/05 23:37:20 gerd
* Initial revision
*
*
*)
